File Coverage

blib/lib/Elatin1.pm
Criterion Covered Total %
statement 865 3080 28.0
branch 944 2674 35.3
condition 99 373 26.5
subroutine 67 125 53.6
pod 7 74 9.4
total 1982 6326 31.3


line stmt bran cond sub pod time code
1             package Elatin1;
2             ######################################################################
3             #
4             # Elatin1 - Run-time routines for Latin1.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin1/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   3278 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         543  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             # 12.3. Delaying use Until Runtime
15             # in Chapter 12. Packages, Libraries, and Modules
16             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
17             # (and so on)
18              
19             # Version numbers should be boring
20             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
21             # For the impatient, the disinterested or those who just want to follow
22             # a recipe, my advice for all modules is this:
23             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
24             # $VERSION = eval $VERSION;
25              
26 200     200   12326 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   971  
  200         283  
  200         28049  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1183 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         259 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         26872 if (CORE::ord('A') != 0x41) {
38             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
39             }
40             }
41              
42             BEGIN {
43              
44             # instead of utf8.pm
45 200     200   12651 CORE::eval q{
  200     200   1047  
  200     72   282  
  200         22733  
  49         4329  
  54         4843  
  42         3939  
  55         5004  
46             no warnings qw(redefine);
47             *utf8::upgrade = sub { CORE::length $_[0] };
48             *utf8::downgrade = sub { 1 };
49             *utf8::encode = sub { };
50             *utf8::decode = sub { 1 };
51             *utf8::is_utf8 = sub { };
52             *utf8::valid = sub { 1 };
53             };
54 200 50       97765 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65 0         0 BEGIN {
66 200     200   497 my $genpkg = "Symbol::";
67 200         8910 my $genseq = 0;
68              
69             sub gensym () {
70 0     0 0 0 my $name = "GEN" . $genseq++;
71              
72             # here, no strict qw(refs); if strict.pm exists
73              
74 0         0 my $ref = \*{$genpkg . $name};
  0         0  
75 0         0 delete $$genpkg{$name};
76 0         0 return $ref;
77             }
78              
79             sub qualify ($;$) {
80 0     0 0 0 my ($name) = @_;
81 0 0 0     0 if (!ref($name) && (Elatin1::index($name, '::') == -1) && (Elatin1::index($name, "'") == -1)) {
      0        
82 0         0 my $pkg;
83 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
84              
85             # Global names: special character, "^xyz", or other.
86 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
89 0         0 $pkg = "main";
90             }
91             else {
92 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
93             }
94 0         0 $name = $pkg . "::" . $name;
95             }
96 0         0 return $name;
97             }
98              
99             sub qualify_to_ref ($;$) {
100              
101             # here, no strict qw(refs); if strict.pm exists
102              
103 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
104             }
105             }
106              
107             # Column: local $@
108             # in Chapter 9. Osaete okitai Perl no kiso
109             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
110             # (and so on)
111              
112             # use strict; if strict.pm exists
113             BEGIN {
114 200 50   200   388 if (CORE::eval { local $@; CORE::require strict }) {
  200         310  
  200         1887  
115 200         21671 strict::->import;
116             }
117             }
118              
119             # P.714 29.2.39. flock
120             # in Chapter 29: Functions
121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
122              
123             # P.863 flock
124             # in Chapter 27: Functions
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126              
127             sub LOCK_SH() {1}
128             sub LOCK_EX() {2}
129             sub LOCK_UN() {8}
130             sub LOCK_NB() {4}
131              
132             # instead of Carp.pm
133             sub carp;
134             sub croak;
135             sub cluck;
136             sub confess;
137              
138             # 6.18. Matching Multiple-Byte Characters
139             # in Chapter 6. Pattern Matching
140             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
141             # (and so on)
142              
143             # regexp of character
144 200     200   13245 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1028  
  200         273  
  200         11180  
145 200     200   11298 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   921  
  200         262  
  200         11417  
146 200     200   10965 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   1235  
  200         270  
  200         13342  
147              
148             #
149             # Latin-1 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   11761 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   932  
  200         361  
  200         298807  
157              
158             #
159             # Latin-1 case conversion
160             #
161             my %lc = ();
162             @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)} =
163             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             my %uc = ();
165             @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)} =
166             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
167             my %fc = ();
168             @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)} =
169             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);
170              
171             if (0) {
172             }
173              
174             elsif (__PACKAGE__ =~ / \b Elatin1 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-1 | iec[- ]?8859-1 | latin-?1 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
183             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
184             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
185             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
186             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
187             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
188             "\xC6" => "\xE6", # LATIN LETTER AE
189             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
190             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
191             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
192             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
193             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
194             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
195             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
196             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
197             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
198             "\xD0" => "\xF0", # LATIN LETTER ETH (Icelandic)
199             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
200             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
201             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
202             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
203             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
204             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
205             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
206             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
207             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
208             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
209             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
210             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
211             "\xDE" => "\xFE", # LATIN LETTER THORN (Icelandic)
212             );
213              
214             %uc = (%uc,
215             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
216             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
217             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
218             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
219             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
220             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
221             "\xE6" => "\xC6", # LATIN LETTER AE
222             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
223             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
224             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
225             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
226             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
227             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
228             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
229             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
230             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
231             "\xF0" => "\xD0", # LATIN LETTER ETH (Icelandic)
232             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
233             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
234             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
235             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
236             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
237             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
238             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
239             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
240             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
241             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
242             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
243             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
244             "\xFE" => "\xDE", # LATIN LETTER THORN (Icelandic)
245             );
246              
247             %fc = (%fc,
248             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
249             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
250             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
251             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
252             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
253             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
254             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
255             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
256             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
257             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
258             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
259             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
260             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
261             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
262             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
263             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
264             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
265             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
266             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
267             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
268             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
269             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
270             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
271             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
272             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
273             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
274             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
275             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
276             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
277             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
278             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
279             );
280             }
281              
282             else {
283             croak "Don't know my package name '@{[__PACKAGE__]}'";
284             }
285              
286             #
287             # @ARGV wildcard globbing
288             #
289             sub import {
290              
291 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
292 0         0 my @argv = ();
293 0         0 for (@ARGV) {
294              
295             # has space
296 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
297 0 0       0 if (my @glob = Elatin1::glob(qq{"$_"})) {
298 0         0 push @argv, @glob;
299             }
300             else {
301 0         0 push @argv, $_;
302             }
303             }
304              
305             # has wildcard metachar
306             elsif (/\A (?:$q_char)*? [*?] /oxms) {
307 0 0       0 if (my @glob = Elatin1::glob($_)) {
308 0         0 push @argv, @glob;
309             }
310             else {
311 0         0 push @argv, $_;
312             }
313             }
314              
315             # no wildcard globbing
316             else {
317 0         0 push @argv, $_;
318             }
319             }
320 0         0 @ARGV = @argv;
321             }
322              
323 0         0 *Char::ord = \&Latin1::ord;
324 0         0 *Char::ord_ = \&Latin1::ord_;
325 0         0 *Char::reverse = \&Latin1::reverse;
326 0         0 *Char::getc = \&Latin1::getc;
327 0         0 *Char::length = \&Latin1::length;
328 0         0 *Char::substr = \&Latin1::substr;
329 0         0 *Char::index = \&Latin1::index;
330 0         0 *Char::rindex = \&Latin1::rindex;
331 0         0 *Char::eval = \&Latin1::eval;
332 0         0 *Char::escape = \&Latin1::escape;
333 0         0 *Char::escape_token = \&Latin1::escape_token;
334 0         0 *Char::escape_script = \&Latin1::escape_script;
335             }
336              
337             # P.230 Care with Prototypes
338             # in Chapter 6: Subroutines
339             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
340             #
341             # If you aren't careful, you can get yourself into trouble with prototypes.
342             # But if you are careful, you can do a lot of neat things with them. This is
343             # all very powerful, of course, and should only be used in moderation to make
344             # the world a better place.
345              
346             # P.332 Care with Prototypes
347             # in Chapter 7: Subroutines
348             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
349             #
350             # If you aren't careful, you can get yourself into trouble with prototypes.
351             # But if you are careful, you can do a lot of neat things with them. This is
352             # all very powerful, of course, and should only be used in moderation to make
353             # the world a better place.
354              
355             #
356             # Prototypes of subroutines
357             #
358       0     sub unimport {}
359             sub Elatin1::split(;$$$);
360             sub Elatin1::tr($$$$;$);
361             sub Elatin1::chop(@);
362             sub Elatin1::index($$;$);
363             sub Elatin1::rindex($$;$);
364             sub Elatin1::lcfirst(@);
365             sub Elatin1::lcfirst_();
366             sub Elatin1::lc(@);
367             sub Elatin1::lc_();
368             sub Elatin1::ucfirst(@);
369             sub Elatin1::ucfirst_();
370             sub Elatin1::uc(@);
371             sub Elatin1::uc_();
372             sub Elatin1::fc(@);
373             sub Elatin1::fc_();
374             sub Elatin1::ignorecase;
375             sub Elatin1::classic_character_class;
376             sub Elatin1::capture;
377             sub Elatin1::chr(;$);
378             sub Elatin1::chr_();
379             sub Elatin1::glob($);
380             sub Elatin1::glob_();
381              
382             sub Latin1::ord(;$);
383             sub Latin1::ord_();
384             sub Latin1::reverse(@);
385             sub Latin1::getc(;*@);
386             sub Latin1::length(;$);
387             sub Latin1::substr($$;$$);
388             sub Latin1::index($$;$);
389             sub Latin1::rindex($$;$);
390             sub Latin1::escape(;$);
391              
392             #
393             # Regexp work
394             #
395 200     200   14005 BEGIN { CORE::eval q{ use vars qw(
  200     200   1107  
  200         306  
  200         70685  
396             $Latin1::re_a
397             $Latin1::re_t
398             $Latin1::re_n
399             $Latin1::re_r
400             ) } }
401              
402             #
403             # Character class
404             #
405 200     200   14699 BEGIN { CORE::eval q{ use vars qw(
  200     200   1097  
  200         306  
  200         2411799  
406             $dot
407             $dot_s
408             $eD
409             $eS
410             $eW
411             $eH
412             $eV
413             $eR
414             $eN
415             $not_alnum
416             $not_alpha
417             $not_ascii
418             $not_blank
419             $not_cntrl
420             $not_digit
421             $not_graph
422             $not_lower
423             $not_lower_i
424             $not_print
425             $not_punct
426             $not_space
427             $not_upper
428             $not_upper_i
429             $not_word
430             $not_xdigit
431             $eb
432             $eB
433             ) } }
434              
435             ${Elatin1::dot} = qr{(?>[^\x0A])};
436             ${Elatin1::dot_s} = qr{(?>[\x00-\xFF])};
437             ${Elatin1::eD} = qr{(?>[^0-9])};
438              
439             # Vertical tabs are now whitespace
440             # \s in a regex now matches a vertical tab in all circumstances.
441             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
442             # ${Elatin1::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
443             # ${Elatin1::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
444             ${Elatin1::eS} = qr{(?>[^\s])};
445              
446             ${Elatin1::eW} = qr{(?>[^0-9A-Z_a-z])};
447             ${Elatin1::eH} = qr{(?>[^\x09\x20])};
448             ${Elatin1::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
449             ${Elatin1::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
450             ${Elatin1::eN} = qr{(?>[^\x0A])};
451             ${Elatin1::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
452             ${Elatin1::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
453             ${Elatin1::not_ascii} = qr{(?>[^\x00-\x7F])};
454             ${Elatin1::not_blank} = qr{(?>[^\x09\x20])};
455             ${Elatin1::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
456             ${Elatin1::not_digit} = qr{(?>[^\x30-\x39])};
457             ${Elatin1::not_graph} = qr{(?>[^\x21-\x7F])};
458             ${Elatin1::not_lower} = qr{(?>[^\x61-\x7A])};
459             ${Elatin1::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
460             # ${Elatin1::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
461             ${Elatin1::not_print} = qr{(?>[^\x20-\x7F])};
462             ${Elatin1::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
463             ${Elatin1::not_space} = qr{(?>[^\s\x0B])};
464             ${Elatin1::not_upper} = qr{(?>[^\x41-\x5A])};
465             ${Elatin1::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
466             # ${Elatin1::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
467             ${Elatin1::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
468             ${Elatin1::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
469             ${Elatin1::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))};
470             ${Elatin1::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]))};
471              
472             # avoid: Name "Elatin1::foo" used only once: possible typo at here.
473             ${Elatin1::dot} = ${Elatin1::dot};
474             ${Elatin1::dot_s} = ${Elatin1::dot_s};
475             ${Elatin1::eD} = ${Elatin1::eD};
476             ${Elatin1::eS} = ${Elatin1::eS};
477             ${Elatin1::eW} = ${Elatin1::eW};
478             ${Elatin1::eH} = ${Elatin1::eH};
479             ${Elatin1::eV} = ${Elatin1::eV};
480             ${Elatin1::eR} = ${Elatin1::eR};
481             ${Elatin1::eN} = ${Elatin1::eN};
482             ${Elatin1::not_alnum} = ${Elatin1::not_alnum};
483             ${Elatin1::not_alpha} = ${Elatin1::not_alpha};
484             ${Elatin1::not_ascii} = ${Elatin1::not_ascii};
485             ${Elatin1::not_blank} = ${Elatin1::not_blank};
486             ${Elatin1::not_cntrl} = ${Elatin1::not_cntrl};
487             ${Elatin1::not_digit} = ${Elatin1::not_digit};
488             ${Elatin1::not_graph} = ${Elatin1::not_graph};
489             ${Elatin1::not_lower} = ${Elatin1::not_lower};
490             ${Elatin1::not_lower_i} = ${Elatin1::not_lower_i};
491             ${Elatin1::not_print} = ${Elatin1::not_print};
492             ${Elatin1::not_punct} = ${Elatin1::not_punct};
493             ${Elatin1::not_space} = ${Elatin1::not_space};
494             ${Elatin1::not_upper} = ${Elatin1::not_upper};
495             ${Elatin1::not_upper_i} = ${Elatin1::not_upper_i};
496             ${Elatin1::not_word} = ${Elatin1::not_word};
497             ${Elatin1::not_xdigit} = ${Elatin1::not_xdigit};
498             ${Elatin1::eb} = ${Elatin1::eb};
499             ${Elatin1::eB} = ${Elatin1::eB};
500              
501             #
502             # Latin-1 split
503             #
504             sub Elatin1::split(;$$$) {
505              
506             # P.794 29.2.161. split
507             # in Chapter 29: Functions
508             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
509              
510             # P.951 split
511             # in Chapter 27: Functions
512             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
513              
514 0     0 0 0 my $pattern = $_[0];
515 0         0 my $string = $_[1];
516 0         0 my $limit = $_[2];
517              
518             # if $pattern is also omitted or is the literal space, " "
519 0 0       0 if (not defined $pattern) {
520 0         0 $pattern = ' ';
521             }
522              
523             # if $string is omitted, the function splits the $_ string
524 0 0       0 if (not defined $string) {
525 0 0       0 if (defined $_) {
526 0         0 $string = $_;
527             }
528             else {
529 0         0 $string = '';
530             }
531             }
532              
533 0         0 my @split = ();
534              
535             # when string is empty
536 0 0       0 if ($string eq '') {
    0          
537              
538             # resulting list value in list context
539 0 0       0 if (wantarray) {
540 0         0 return @split;
541             }
542              
543             # count of substrings in scalar context
544             else {
545 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
546 0         0 @_ = @split;
547 0         0 return scalar @_;
548             }
549             }
550              
551             # split's first argument is more consistently interpreted
552             #
553             # After some changes earlier in v5.17, split's behavior has been simplified:
554             # if the PATTERN argument evaluates to a string containing one space, it is
555             # treated the way that a literal string containing one space once was.
556             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
557              
558             # if $pattern is also omitted or is the literal space, " ", the function splits
559             # on whitespace, /\s+/, after skipping any leading whitespace
560             # (and so on)
561              
562             elsif ($pattern eq ' ') {
563 0 0       0 if (not defined $limit) {
564 0         0 return CORE::split(' ', $string);
565             }
566             else {
567 0         0 return CORE::split(' ', $string, $limit);
568             }
569             }
570              
571             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
572 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
573              
574             # a pattern capable of matching either the null string or something longer than the
575             # null string will split the value of $string into separate characters wherever it
576             # matches the null string between characters
577             # (and so on)
578              
579 0 0       0 if ('' =~ / \A $pattern \z /xms) {
580 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
581 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
582              
583             # P.1024 Appendix W.10 Multibyte Processing
584             # of ISBN 1-56592-224-7 CJKV Information Processing
585             # (and so on)
586              
587             # the //m modifier is assumed when you split on the pattern /^/
588             # (and so on)
589              
590             # V
591 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
592              
593             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
594             # is included in the resulting list, interspersed with the fields that are ordinarily returned
595             # (and so on)
596              
597 0         0 local $@;
598 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
599 0         0 push @split, CORE::eval('$' . $digit);
600             }
601             }
602             }
603              
604             else {
605 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
606              
607             # V
608 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
609 0         0 local $@;
610 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
611 0         0 push @split, CORE::eval('$' . $digit);
612             }
613             }
614             }
615             }
616              
617             elsif ($limit > 0) {
618 0 0       0 if ('' =~ / \A $pattern \z /xms) {
619 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
620 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
621              
622             # V
623 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
624 0         0 local $@;
625 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
626 0         0 push @split, CORE::eval('$' . $digit);
627             }
628             }
629             }
630             }
631             else {
632 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
633 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
634              
635             # V
636 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
637 0         0 local $@;
638 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
639 0         0 push @split, CORE::eval('$' . $digit);
640             }
641             }
642             }
643             }
644             }
645              
646 0 0       0 if (CORE::length($string) > 0) {
647 0         0 push @split, $string;
648             }
649              
650             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
651 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
652 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
653 0         0 pop @split;
654             }
655             }
656              
657             # resulting list value in list context
658 0 0       0 if (wantarray) {
659 0         0 return @split;
660             }
661              
662             # count of substrings in scalar context
663             else {
664 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
665 0         0 @_ = @split;
666 0         0 return scalar @_;
667             }
668             }
669              
670             #
671             # get last subexpression offsets
672             #
673             sub _last_subexpression_offsets {
674 0     0   0 my $pattern = $_[0];
675              
676             # remove comment
677 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
678              
679 0         0 my $modifier = '';
680 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
681 0         0 $modifier = $1;
682 0         0 $modifier =~ s/-[A-Za-z]*//;
683             }
684              
685             # with /x modifier
686 0         0 my @char = ();
687 0 0       0 if ($modifier =~ /x/oxms) {
688 0         0 @char = $pattern =~ /\G((?>
689             [^\\\#\[\(] |
690             \\ $q_char |
691             \# (?>[^\n]*) $ |
692             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
693             \(\? |
694             $q_char
695             ))/oxmsg;
696             }
697              
698             # without /x modifier
699             else {
700 0         0 @char = $pattern =~ /\G((?>
701             [^\\\[\(] |
702             \\ $q_char |
703             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
704             \(\? |
705             $q_char
706             ))/oxmsg;
707             }
708              
709 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
710             }
711              
712             #
713             # Latin-1 transliteration (tr///)
714             #
715             sub Elatin1::tr($$$$;$) {
716              
717 0     0 0 0 my $bind_operator = $_[1];
718 0         0 my $searchlist = $_[2];
719 0         0 my $replacementlist = $_[3];
720 0   0     0 my $modifier = $_[4] || '';
721              
722 0 0       0 if ($modifier =~ /r/oxms) {
723 0 0       0 if ($bind_operator =~ / !~ /oxms) {
724 0         0 croak "Using !~ with tr///r doesn't make sense";
725             }
726             }
727              
728 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
729 0         0 my @searchlist = _charlist_tr($searchlist);
730 0         0 my @replacementlist = _charlist_tr($replacementlist);
731              
732 0         0 my %tr = ();
733 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
734 0 0       0 if (not exists $tr{$searchlist[$i]}) {
735 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
736 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
737             }
738             elsif ($modifier =~ /d/oxms) {
739 0         0 $tr{$searchlist[$i]} = '';
740             }
741             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
742 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
743             }
744             else {
745 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
746             }
747             }
748             }
749              
750 0         0 my $tr = 0;
751 0         0 my $replaced = '';
752 0 0       0 if ($modifier =~ /c/oxms) {
753 0         0 while (defined(my $char = shift @char)) {
754 0 0       0 if (not exists $tr{$char}) {
755 0 0       0 if (defined $replacementlist[0]) {
756 0         0 $replaced .= $replacementlist[0];
757             }
758 0         0 $tr++;
759 0 0       0 if ($modifier =~ /s/oxms) {
760 0   0     0 while (@char and (not exists $tr{$char[0]})) {
761 0         0 shift @char;
762 0         0 $tr++;
763             }
764             }
765             }
766             else {
767 0         0 $replaced .= $char;
768             }
769             }
770             }
771             else {
772 0         0 while (defined(my $char = shift @char)) {
773 0 0       0 if (exists $tr{$char}) {
774 0         0 $replaced .= $tr{$char};
775 0         0 $tr++;
776 0 0       0 if ($modifier =~ /s/oxms) {
777 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
778 0         0 shift @char;
779 0         0 $tr++;
780             }
781             }
782             }
783             else {
784 0         0 $replaced .= $char;
785             }
786             }
787             }
788              
789 0 0       0 if ($modifier =~ /r/oxms) {
790 0         0 return $replaced;
791             }
792             else {
793 0         0 $_[0] = $replaced;
794 0 0       0 if ($bind_operator =~ / !~ /oxms) {
795 0         0 return not $tr;
796             }
797             else {
798 0         0 return $tr;
799             }
800             }
801             }
802              
803             #
804             # Latin-1 chop
805             #
806             sub Elatin1::chop(@) {
807              
808 0     0 0 0 my $chop;
809 0 0       0 if (@_ == 0) {
810 0         0 my @char = /\G (?>$q_char) /oxmsg;
811 0         0 $chop = pop @char;
812 0         0 $_ = join '', @char;
813             }
814             else {
815 0         0 for (@_) {
816 0         0 my @char = /\G (?>$q_char) /oxmsg;
817 0         0 $chop = pop @char;
818 0         0 $_ = join '', @char;
819             }
820             }
821 0         0 return $chop;
822             }
823              
824             #
825             # Latin-1 index by octet
826             #
827             sub Elatin1::index($$;$) {
828              
829 0     0 1 0 my($str,$substr,$position) = @_;
830 0   0     0 $position ||= 0;
831 0         0 my $pos = 0;
832              
833 0         0 while ($pos < CORE::length($str)) {
834 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
835 0 0       0 if ($pos >= $position) {
836 0         0 return $pos;
837             }
838             }
839 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
840 0         0 $pos += CORE::length($1);
841             }
842             else {
843 0         0 $pos += 1;
844             }
845             }
846 0         0 return -1;
847             }
848              
849             #
850             # Latin-1 reverse index
851             #
852             sub Elatin1::rindex($$;$) {
853              
854 0     0 0 0 my($str,$substr,$position) = @_;
855 0   0     0 $position ||= CORE::length($str) - 1;
856 0         0 my $pos = 0;
857 0         0 my $rindex = -1;
858              
859 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
860 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
861 0         0 $rindex = $pos;
862             }
863 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
864 0         0 $pos += CORE::length($1);
865             }
866             else {
867 0         0 $pos += 1;
868             }
869             }
870 0         0 return $rindex;
871             }
872              
873             #
874             # Latin-1 lower case first with parameter
875             #
876             sub Elatin1::lcfirst(@) {
877 0 0   0 0 0 if (@_) {
878 0         0 my $s = shift @_;
879 0 0 0     0 if (@_ and wantarray) {
880 0         0 return Elatin1::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
881             }
882             else {
883 0         0 return Elatin1::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
884             }
885             }
886             else {
887 0         0 return Elatin1::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
888             }
889             }
890              
891             #
892             # Latin-1 lower case first without parameter
893             #
894             sub Elatin1::lcfirst_() {
895 0     0 0 0 return Elatin1::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
896             }
897              
898             #
899             # Latin-1 lower case with parameter
900             #
901             sub Elatin1::lc(@) {
902 0 0   0 0 0 if (@_) {
903 0         0 my $s = shift @_;
904 0 0 0     0 if (@_ and wantarray) {
905 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
906             }
907             else {
908 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
909             }
910             }
911             else {
912 0         0 return Elatin1::lc_();
913             }
914             }
915              
916             #
917             # Latin-1 lower case without parameter
918             #
919             sub Elatin1::lc_() {
920 0     0 0 0 my $s = $_;
921 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
922             }
923              
924             #
925             # Latin-1 upper case first with parameter
926             #
927             sub Elatin1::ucfirst(@) {
928 0 0   0 0 0 if (@_) {
929 0         0 my $s = shift @_;
930 0 0 0     0 if (@_ and wantarray) {
931 0         0 return Elatin1::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
932             }
933             else {
934 0         0 return Elatin1::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
935             }
936             }
937             else {
938 0         0 return Elatin1::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
939             }
940             }
941              
942             #
943             # Latin-1 upper case first without parameter
944             #
945             sub Elatin1::ucfirst_() {
946 0     0 0 0 return Elatin1::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
947             }
948              
949             #
950             # Latin-1 upper case with parameter
951             #
952             sub Elatin1::uc(@) {
953 174 50   174 0 264 if (@_) {
954 174         184 my $s = shift @_;
955 174 50 33     374 if (@_ and wantarray) {
956 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
957             }
958             else {
959 174 100       601 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         687  
960             }
961             }
962             else {
963 0         0 return Elatin1::uc_();
964             }
965             }
966              
967             #
968             # Latin-1 upper case without parameter
969             #
970             sub Elatin1::uc_() {
971 0     0 0 0 my $s = $_;
972 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
973             }
974              
975             #
976             # Latin-1 fold case with parameter
977             #
978             sub Elatin1::fc(@) {
979 197 50   197 0 295 if (@_) {
980 197         200 my $s = shift @_;
981 197 50 33     397 if (@_ and wantarray) {
982 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
983             }
984             else {
985 197 100       564 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         1255  
986             }
987             }
988             else {
989 0         0 return Elatin1::fc_();
990             }
991             }
992              
993             #
994             # Latin-1 fold case without parameter
995             #
996             sub Elatin1::fc_() {
997 0     0 0 0 my $s = $_;
998 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
999             }
1000              
1001             #
1002             # Latin-1 regexp capture
1003             #
1004             {
1005             sub Elatin1::capture {
1006 0     0 1 0 return $_[0];
1007             }
1008             }
1009              
1010             #
1011             # Latin-1 regexp ignore case modifier
1012             #
1013             sub Elatin1::ignorecase {
1014              
1015 0     0 0 0 my @string = @_;
1016 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1017              
1018             # ignore case of $scalar or @array
1019 0         0 for my $string (@string) {
1020              
1021             # split regexp
1022 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1023              
1024             # unescape character
1025 0         0 for (my $i=0; $i <= $#char; $i++) {
1026 0 0       0 next if not defined $char[$i];
1027              
1028             # open character class [...]
1029 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1030 0         0 my $left = $i;
1031              
1032             # [] make die "unmatched [] in regexp ...\n"
1033              
1034 0 0       0 if ($char[$i+1] eq ']') {
1035 0         0 $i++;
1036             }
1037              
1038 0         0 while (1) {
1039 0 0       0 if (++$i > $#char) {
1040 0         0 croak "Unmatched [] in regexp";
1041             }
1042 0 0       0 if ($char[$i] eq ']') {
1043 0         0 my $right = $i;
1044 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1045              
1046             # escape character
1047 0         0 for my $char (@charlist) {
1048 0 0       0 if (0) {
1049             }
1050              
1051 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1052 0         0 $char = '\\' . $char;
1053             }
1054             }
1055              
1056             # [...]
1057 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1058              
1059 0         0 $i = $left;
1060 0         0 last;
1061             }
1062             }
1063             }
1064              
1065             # open character class [^...]
1066             elsif ($char[$i] eq '[^') {
1067 0         0 my $left = $i;
1068              
1069             # [^] make die "unmatched [] in regexp ...\n"
1070              
1071 0 0       0 if ($char[$i+1] eq ']') {
1072 0         0 $i++;
1073             }
1074              
1075 0         0 while (1) {
1076 0 0       0 if (++$i > $#char) {
1077 0         0 croak "Unmatched [] in regexp";
1078             }
1079 0 0       0 if ($char[$i] eq ']') {
1080 0         0 my $right = $i;
1081 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1082              
1083             # escape character
1084 0         0 for my $char (@charlist) {
1085 0 0       0 if (0) {
1086             }
1087              
1088 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1089 0         0 $char = '\\' . $char;
1090             }
1091             }
1092              
1093             # [^...]
1094 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1095              
1096 0         0 $i = $left;
1097 0         0 last;
1098             }
1099             }
1100             }
1101              
1102             # rewrite classic character class or escape character
1103             elsif (my $char = classic_character_class($char[$i])) {
1104 0         0 $char[$i] = $char;
1105             }
1106              
1107             # with /i modifier
1108             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1109 0         0 my $uc = Elatin1::uc($char[$i]);
1110 0         0 my $fc = Elatin1::fc($char[$i]);
1111 0 0       0 if ($uc ne $fc) {
1112 0 0       0 if (CORE::length($fc) == 1) {
1113 0         0 $char[$i] = '[' . $uc . $fc . ']';
1114             }
1115             else {
1116 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1117             }
1118             }
1119             }
1120             }
1121              
1122             # characterize
1123 0         0 for (my $i=0; $i <= $#char; $i++) {
1124 0 0       0 next if not defined $char[$i];
1125              
1126 0 0       0 if (0) {
1127             }
1128              
1129             # quote character before ? + * {
1130 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1131 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1132 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1133             }
1134             }
1135             }
1136              
1137 0         0 $string = join '', @char;
1138             }
1139              
1140             # make regexp string
1141 0         0 return @string;
1142             }
1143              
1144             #
1145             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1146             #
1147             sub Elatin1::classic_character_class {
1148 1862     1862 0 1815 my($char) = @_;
1149              
1150             return {
1151             '\D' => '${Elatin1::eD}',
1152             '\S' => '${Elatin1::eS}',
1153             '\W' => '${Elatin1::eW}',
1154             '\d' => '[0-9]',
1155              
1156             # Before Perl 5.6, \s only matched the five whitespace characters
1157             # tab, newline, form-feed, carriage return, and the space character
1158             # itself, which, taken together, is the character class [\t\n\f\r ].
1159              
1160             # Vertical tabs are now whitespace
1161             # \s in a regex now matches a vertical tab in all circumstances.
1162             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1163             # \t \n \v \f \r space
1164             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1165             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1166             '\s' => '\s',
1167              
1168             '\w' => '[0-9A-Z_a-z]',
1169             '\C' => '[\x00-\xFF]',
1170             '\X' => 'X',
1171              
1172             # \h \v \H \V
1173              
1174             # P.114 Character Class Shortcuts
1175             # in Chapter 7: In the World of Regular Expressions
1176             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1177              
1178             # P.357 13.2.3 Whitespace
1179             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1180             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1181             #
1182             # 0x00009 CHARACTER TABULATION h s
1183             # 0x0000a LINE FEED (LF) vs
1184             # 0x0000b LINE TABULATION v
1185             # 0x0000c FORM FEED (FF) vs
1186             # 0x0000d CARRIAGE RETURN (CR) vs
1187             # 0x00020 SPACE h s
1188              
1189             # P.196 Table 5-9. Alphanumeric regex metasymbols
1190             # in Chapter 5. Pattern Matching
1191             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1192              
1193             # (and so on)
1194              
1195             '\H' => '${Elatin1::eH}',
1196             '\V' => '${Elatin1::eV}',
1197             '\h' => '[\x09\x20]',
1198             '\v' => '[\x0A\x0B\x0C\x0D]',
1199             '\R' => '${Elatin1::eR}',
1200              
1201             # \N
1202             #
1203             # http://perldoc.perl.org/perlre.html
1204             # Character Classes and other Special Escapes
1205             # Any character but \n (experimental). Not affected by /s modifier
1206              
1207             '\N' => '${Elatin1::eN}',
1208              
1209             # \b \B
1210              
1211             # P.180 Boundaries: The \b and \B Assertions
1212             # in Chapter 5: Pattern Matching
1213             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1214              
1215             # P.219 Boundaries: The \b and \B Assertions
1216             # in Chapter 5: Pattern Matching
1217             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1218              
1219             # \b really means (?:(?<=\w)(?!\w)|(?
1220             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1221             '\b' => '${Elatin1::eb}',
1222              
1223             # \B really means (?:(?<=\w)(?=\w)|(?
1224             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1225             '\B' => '${Elatin1::eB}',
1226              
1227 1862   100     89981 }->{$char} || '';
1228             }
1229              
1230             #
1231             # prepare Latin-1 characters per length
1232             #
1233              
1234             # 1 octet characters
1235             my @chars1 = ();
1236             sub chars1 {
1237 0 0   0 0 0 if (@chars1) {
1238 0         0 return @chars1;
1239             }
1240 0 0       0 if (exists $range_tr{1}) {
1241 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1242 0         0 while (my @range = splice(@ranges,0,1)) {
1243 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1244 0         0 push @chars1, pack 'C', $oct0;
1245             }
1246             }
1247             }
1248 0         0 return @chars1;
1249             }
1250              
1251             # 2 octets characters
1252             my @chars2 = ();
1253             sub chars2 {
1254 0 0   0 0 0 if (@chars2) {
1255 0         0 return @chars2;
1256             }
1257 0 0       0 if (exists $range_tr{2}) {
1258 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1259 0         0 while (my @range = splice(@ranges,0,2)) {
1260 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1261 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1262 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1263             }
1264             }
1265             }
1266             }
1267 0         0 return @chars2;
1268             }
1269              
1270             # 3 octets characters
1271             my @chars3 = ();
1272             sub chars3 {
1273 0 0   0 0 0 if (@chars3) {
1274 0         0 return @chars3;
1275             }
1276 0 0       0 if (exists $range_tr{3}) {
1277 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1278 0         0 while (my @range = splice(@ranges,0,3)) {
1279 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1280 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1281 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1282 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1283             }
1284             }
1285             }
1286             }
1287             }
1288 0         0 return @chars3;
1289             }
1290              
1291             # 4 octets characters
1292             my @chars4 = ();
1293             sub chars4 {
1294 0 0   0 0 0 if (@chars4) {
1295 0         0 return @chars4;
1296             }
1297 0 0       0 if (exists $range_tr{4}) {
1298 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1299 0         0 while (my @range = splice(@ranges,0,4)) {
1300 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1301 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1302 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1303 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1304 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1305             }
1306             }
1307             }
1308             }
1309             }
1310             }
1311 0         0 return @chars4;
1312             }
1313              
1314             #
1315             # Latin-1 open character list for tr
1316             #
1317             sub _charlist_tr {
1318              
1319 0     0   0 local $_ = shift @_;
1320              
1321             # unescape character
1322 0         0 my @char = ();
1323 0         0 while (not /\G \z/oxmsgc) {
1324 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1325 0         0 push @char, '\-';
1326             }
1327             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1328 0         0 push @char, CORE::chr(oct $1);
1329             }
1330             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1331 0         0 push @char, CORE::chr(hex $1);
1332             }
1333             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1334 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1335             }
1336             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1337             push @char, {
1338             '\0' => "\0",
1339             '\n' => "\n",
1340             '\r' => "\r",
1341             '\t' => "\t",
1342             '\f' => "\f",
1343             '\b' => "\x08", # \b means backspace in character class
1344             '\a' => "\a",
1345             '\e' => "\e",
1346 0         0 }->{$1};
1347             }
1348             elsif (/\G \\ ($q_char) /oxmsgc) {
1349 0         0 push @char, $1;
1350             }
1351             elsif (/\G ($q_char) /oxmsgc) {
1352 0         0 push @char, $1;
1353             }
1354             }
1355              
1356             # join separated multiple-octet
1357 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1358              
1359             # unescape '-'
1360 0         0 my @i = ();
1361 0         0 for my $i (0 .. $#char) {
1362 0 0       0 if ($char[$i] eq '\-') {
    0          
1363 0         0 $char[$i] = '-';
1364             }
1365             elsif ($char[$i] eq '-') {
1366 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1367 0         0 push @i, $i;
1368             }
1369             }
1370             }
1371              
1372             # open character list (reverse for splice)
1373 0         0 for my $i (CORE::reverse @i) {
1374 0         0 my @range = ();
1375              
1376             # range error
1377 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1378 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1379             }
1380              
1381             # range of multiple-octet code
1382 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1383 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1384 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1385             }
1386             elsif (CORE::length($char[$i+1]) == 2) {
1387 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1388 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1389             }
1390             elsif (CORE::length($char[$i+1]) == 3) {
1391 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1392 0         0 push @range, chars2();
1393 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1394             }
1395             elsif (CORE::length($char[$i+1]) == 4) {
1396 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1397 0         0 push @range, chars2();
1398 0         0 push @range, chars3();
1399 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1400             }
1401             else {
1402 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1403             }
1404             }
1405             elsif (CORE::length($char[$i-1]) == 2) {
1406 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1407 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1408             }
1409             elsif (CORE::length($char[$i+1]) == 3) {
1410 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1411 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1412             }
1413             elsif (CORE::length($char[$i+1]) == 4) {
1414 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1415 0         0 push @range, chars3();
1416 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1417             }
1418             else {
1419 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1420             }
1421             }
1422             elsif (CORE::length($char[$i-1]) == 3) {
1423 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1424 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1425             }
1426             elsif (CORE::length($char[$i+1]) == 4) {
1427 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1428 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1429             }
1430             else {
1431 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1432             }
1433             }
1434             elsif (CORE::length($char[$i-1]) == 4) {
1435 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1436 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1437             }
1438             else {
1439 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1440             }
1441             }
1442             else {
1443 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1444             }
1445              
1446 0         0 splice @char, $i-1, 3, @range;
1447             }
1448              
1449 0         0 return @char;
1450             }
1451              
1452             #
1453             # Latin-1 open character class
1454             #
1455             sub _cc {
1456 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1457 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1458             }
1459             elsif (scalar(@_) == 1) {
1460 0         0 return sprintf('\x%02X',$_[0]);
1461             }
1462             elsif (scalar(@_) == 2) {
1463 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1464 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1465             }
1466             elsif ($_[0] == $_[1]) {
1467 0         0 return sprintf('\x%02X',$_[0]);
1468             }
1469             elsif (($_[0]+1) == $_[1]) {
1470 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1471             }
1472             else {
1473 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1474             }
1475             }
1476             else {
1477 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1478             }
1479             }
1480              
1481             #
1482             # Latin-1 octet range
1483             #
1484             sub _octets {
1485 182     182   368 my $length = shift @_;
1486              
1487 182 50       363 if ($length == 1) {
1488 182         630 my($a1) = unpack 'C', $_[0];
1489 182         348 my($z1) = unpack 'C', $_[1];
1490              
1491 182 50       422 if ($a1 > $z1) {
1492 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1493             }
1494              
1495 182 50       560 if ($a1 == $z1) {
    50          
1496 0         0 return sprintf('\x%02X',$a1);
1497             }
1498             elsif (($a1+1) == $z1) {
1499 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1500             }
1501             else {
1502 182         1495 return sprintf('\x%02X-\x%02X',$a1,$z1);
1503             }
1504             }
1505             else {
1506 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1507             }
1508             }
1509              
1510             #
1511             # Latin-1 range regexp
1512             #
1513             sub _range_regexp {
1514 182     182   313 my($length,$first,$last) = @_;
1515              
1516 182         283 my @range_regexp = ();
1517 182 50       577 if (not exists $range_tr{$length}) {
1518 0         0 return @range_regexp;
1519             }
1520              
1521 182         227 my @ranges = @{ $range_tr{$length} };
  182         560  
1522 182         720 while (my @range = splice(@ranges,0,$length)) {
1523 182         245 my $min = '';
1524 182         197 my $max = '';
1525 182         503 for (my $i=0; $i < $length; $i++) {
1526 182         844 $min .= pack 'C', $range[$i][0];
1527 182         563 $max .= pack 'C', $range[$i][-1];
1528             }
1529              
1530             # min___max
1531             # FIRST_____________LAST
1532             # (nothing)
1533              
1534 182 50 33     2642 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1535             }
1536              
1537             # **********
1538             # min_________max
1539             # FIRST_____________LAST
1540             # **********
1541              
1542             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1543 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1544             }
1545              
1546             # **********************
1547             # min________________max
1548             # FIRST_____________LAST
1549             # **********************
1550              
1551             elsif (($min eq $first) and ($max eq $last)) {
1552 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1553             }
1554              
1555             # *********
1556             # min___max
1557             # FIRST_____________LAST
1558             # *********
1559              
1560             elsif (($first le $min) and ($max le $last)) {
1561 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1562             }
1563              
1564             # **********************
1565             # min__________________________max
1566             # FIRST_____________LAST
1567             # **********************
1568              
1569             elsif (($min le $first) and ($last le $max)) {
1570 182         519 push @range_regexp, _octets($length,$first,$last,$min,$max);
1571             }
1572              
1573             # *********
1574             # min________max
1575             # FIRST_____________LAST
1576             # *********
1577              
1578             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1579 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1580             }
1581              
1582             # min___max
1583             # FIRST_____________LAST
1584             # (nothing)
1585              
1586             elsif ($last lt $min) {
1587             }
1588              
1589             else {
1590 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1591             }
1592             }
1593              
1594 182         447 return @range_regexp;
1595             }
1596              
1597             #
1598             # Latin-1 open character list for qr and not qr
1599             #
1600             sub _charlist {
1601              
1602 358     358   546 my $modifier = pop @_;
1603 358         762 my @char = @_;
1604              
1605 358 100       839 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1606              
1607             # unescape character
1608 358         1183 for (my $i=0; $i <= $#char; $i++) {
1609              
1610             # escape - to ...
1611 1125 100 100     11456 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1612 206 100 100     1074 if ((0 < $i) and ($i < $#char)) {
1613 182         454 $char[$i] = '...';
1614             }
1615             }
1616              
1617             # octal escape sequence
1618             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1619 0         0 $char[$i] = octchr($1);
1620             }
1621              
1622             # hexadecimal escape sequence
1623             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1624 0         0 $char[$i] = hexchr($1);
1625             }
1626              
1627             # \b{...} --> b\{...}
1628             # \B{...} --> B\{...}
1629             # \N{CHARNAME} --> N\{CHARNAME}
1630             # \p{PROPERTY} --> p\{PROPERTY}
1631             # \P{PROPERTY} --> P\{PROPERTY}
1632             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1633 0         0 $char[$i] = $1 . '\\' . $2;
1634             }
1635              
1636             # \p, \P, \X --> p, P, X
1637             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1638 0         0 $char[$i] = $1;
1639             }
1640              
1641             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1642 0         0 $char[$i] = CORE::chr oct $1;
1643             }
1644             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1645 22         141 $char[$i] = CORE::chr hex $1;
1646             }
1647             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1648 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1649             }
1650             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1651             $char[$i] = {
1652             '\0' => "\0",
1653             '\n' => "\n",
1654             '\r' => "\r",
1655             '\t' => "\t",
1656             '\f' => "\f",
1657             '\b' => "\x08", # \b means backspace in character class
1658             '\a' => "\a",
1659             '\e' => "\e",
1660             '\d' => '[0-9]',
1661              
1662             # Vertical tabs are now whitespace
1663             # \s in a regex now matches a vertical tab in all circumstances.
1664             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1665             # \t \n \v \f \r space
1666             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1667             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1668             '\s' => '\s',
1669              
1670             '\w' => '[0-9A-Z_a-z]',
1671             '\D' => '${Elatin1::eD}',
1672             '\S' => '${Elatin1::eS}',
1673             '\W' => '${Elatin1::eW}',
1674              
1675             '\H' => '${Elatin1::eH}',
1676             '\V' => '${Elatin1::eV}',
1677             '\h' => '[\x09\x20]',
1678             '\v' => '[\x0A\x0B\x0C\x0D]',
1679             '\R' => '${Elatin1::eR}',
1680              
1681 25         434 }->{$1};
1682             }
1683              
1684             # POSIX-style character classes
1685             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1686             $char[$i] = {
1687              
1688             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1689             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1690             '[:^lower:]' => '${Elatin1::not_lower_i}',
1691             '[:^upper:]' => '${Elatin1::not_upper_i}',
1692              
1693 8         77 }->{$1};
1694             }
1695             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1696             $char[$i] = {
1697              
1698             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1699             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1700             '[:ascii:]' => '[\x00-\x7F]',
1701             '[:blank:]' => '[\x09\x20]',
1702             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1703             '[:digit:]' => '[\x30-\x39]',
1704             '[:graph:]' => '[\x21-\x7F]',
1705             '[:lower:]' => '[\x61-\x7A]',
1706             '[:print:]' => '[\x20-\x7F]',
1707             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1708              
1709             # P.174 POSIX-Style Character Classes
1710             # in Chapter 5: Pattern Matching
1711             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1712              
1713             # P.311 11.2.4 Character Classes and other Special Escapes
1714             # in Chapter 11: perlre: Perl regular expressions
1715             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1716              
1717             # P.210 POSIX-Style Character Classes
1718             # in Chapter 5: Pattern Matching
1719             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1720              
1721             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1722              
1723             '[:upper:]' => '[\x41-\x5A]',
1724             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1725             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1726             '[:^alnum:]' => '${Elatin1::not_alnum}',
1727             '[:^alpha:]' => '${Elatin1::not_alpha}',
1728             '[:^ascii:]' => '${Elatin1::not_ascii}',
1729             '[:^blank:]' => '${Elatin1::not_blank}',
1730             '[:^cntrl:]' => '${Elatin1::not_cntrl}',
1731             '[:^digit:]' => '${Elatin1::not_digit}',
1732             '[:^graph:]' => '${Elatin1::not_graph}',
1733             '[:^lower:]' => '${Elatin1::not_lower}',
1734             '[:^print:]' => '${Elatin1::not_print}',
1735             '[:^punct:]' => '${Elatin1::not_punct}',
1736             '[:^space:]' => '${Elatin1::not_space}',
1737             '[:^upper:]' => '${Elatin1::not_upper}',
1738             '[:^word:]' => '${Elatin1::not_word}',
1739             '[:^xdigit:]' => '${Elatin1::not_xdigit}',
1740              
1741 70         1328 }->{$1};
1742             }
1743             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1744 7         32 $char[$i] = $1;
1745             }
1746             }
1747              
1748             # open character list
1749 358         588 my @singleoctet = ();
1750 358         481 my @multipleoctet = ();
1751 358         940 for (my $i=0; $i <= $#char; ) {
1752              
1753             # escaped -
1754 943 100 100     5384 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1755 182         208 $i += 1;
1756 182         380 next;
1757             }
1758              
1759             # make range regexp
1760             elsif ($char[$i] eq '...') {
1761              
1762             # range error
1763 182 50       884 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1764 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1765             }
1766             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1767 182 50       553 if ($char[$i-1] gt $char[$i+1]) {
1768 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]);
1769             }
1770             }
1771              
1772             # make range regexp per length
1773 182         636 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1774 182         268 my @regexp = ();
1775              
1776             # is first and last
1777 182 50 33     1006 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1778 182         630 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1779             }
1780              
1781             # is first
1782             elsif ($length == CORE::length($char[$i-1])) {
1783 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1784             }
1785              
1786             # is inside in first and last
1787             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1788 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1789             }
1790              
1791             # is last
1792             elsif ($length == CORE::length($char[$i+1])) {
1793 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1794             }
1795              
1796             else {
1797 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1798             }
1799              
1800 182 50       462 if ($length == 1) {
1801 182         471 push @singleoctet, @regexp;
1802             }
1803             else {
1804 0         0 push @multipleoctet, @regexp;
1805             }
1806             }
1807              
1808 182         506 $i += 2;
1809             }
1810              
1811             # with /i modifier
1812             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1813 493 100       659 if ($modifier =~ /i/oxms) {
1814 24         57 my $uc = Elatin1::uc($char[$i]);
1815 24         61 my $fc = Elatin1::fc($char[$i]);
1816 24 100       45 if ($uc ne $fc) {
1817 12 50       28 if (CORE::length($fc) == 1) {
1818 12         22 push @singleoctet, $uc, $fc;
1819             }
1820             else {
1821 0         0 push @singleoctet, $uc;
1822 0         0 push @multipleoctet, $fc;
1823             }
1824             }
1825             else {
1826 12         27 push @singleoctet, $char[$i];
1827             }
1828             }
1829             else {
1830 469         693 push @singleoctet, $char[$i];
1831             }
1832 493         858 $i += 1;
1833             }
1834              
1835             # single character of single octet code
1836             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1837 0         0 push @singleoctet, "\t", "\x20";
1838 0         0 $i += 1;
1839             }
1840             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1841 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1842 0         0 $i += 1;
1843             }
1844             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1845 2         5 push @singleoctet, $char[$i];
1846 2         6 $i += 1;
1847             }
1848              
1849             # single character of multiple-octet code
1850             else {
1851 84         131 push @multipleoctet, $char[$i];
1852 84         171 $i += 1;
1853             }
1854             }
1855              
1856             # quote metachar
1857 358         745 for (@singleoctet) {
1858 689 50       4604 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1859 0         0 $_ = '-';
1860             }
1861             elsif (/\A \n \z/oxms) {
1862 8         19 $_ = '\n';
1863             }
1864             elsif (/\A \r \z/oxms) {
1865 8         14 $_ = '\r';
1866             }
1867             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1868 60         220 $_ = sprintf('\x%02X', CORE::ord $1);
1869             }
1870             elsif (/\A [\x00-\xFF] \z/oxms) {
1871 429         873 $_ = quotemeta $_;
1872             }
1873             }
1874              
1875             # return character list
1876 358         1177 return \@singleoctet, \@multipleoctet;
1877             }
1878              
1879             #
1880             # Latin-1 octal escape sequence
1881             #
1882             sub octchr {
1883 5     5 0 11 my($octdigit) = @_;
1884              
1885 5         7 my @binary = ();
1886 5         16 for my $octal (split(//,$octdigit)) {
1887             push @binary, {
1888             '0' => '000',
1889             '1' => '001',
1890             '2' => '010',
1891             '3' => '011',
1892             '4' => '100',
1893             '5' => '101',
1894             '6' => '110',
1895             '7' => '111',
1896 50         143 }->{$octal};
1897             }
1898 5         13 my $binary = join '', @binary;
1899              
1900             my $octchr = {
1901             # 1234567
1902             1 => pack('B*', "0000000$binary"),
1903             2 => pack('B*', "000000$binary"),
1904             3 => pack('B*', "00000$binary"),
1905             4 => pack('B*', "0000$binary"),
1906             5 => pack('B*', "000$binary"),
1907             6 => pack('B*', "00$binary"),
1908             7 => pack('B*', "0$binary"),
1909             0 => pack('B*', "$binary"),
1910              
1911 5         54 }->{CORE::length($binary) % 8};
1912              
1913 5         17 return $octchr;
1914             }
1915              
1916             #
1917             # Latin-1 hexadecimal escape sequence
1918             #
1919             sub hexchr {
1920 5     5 0 10 my($hexdigit) = @_;
1921              
1922             my $hexchr = {
1923             1 => pack('H*', "0$hexdigit"),
1924             0 => pack('H*', "$hexdigit"),
1925              
1926 5         38 }->{CORE::length($_[0]) % 2};
1927              
1928 5         16 return $hexchr;
1929             }
1930              
1931             #
1932             # Latin-1 open character list for qr
1933             #
1934             sub charlist_qr {
1935              
1936 314     314 0 600 my $modifier = pop @_;
1937 314         852 my @char = @_;
1938              
1939 314         859 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1940 314         683 my @singleoctet = @$singleoctet;
1941 314         485 my @multipleoctet = @$multipleoctet;
1942              
1943             # return character list
1944 314 100       771 if (scalar(@singleoctet) >= 1) {
1945              
1946             # with /i modifier
1947 236 100       540 if ($modifier =~ m/i/oxms) {
1948 22         44 my %singleoctet_ignorecase = ();
1949 22         39 for (@singleoctet) {
1950 46   100     285 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1951 46         178 for my $ord (hex($1) .. hex($2)) {
1952 66         95 my $char = CORE::chr($ord);
1953 66         115 my $uc = Elatin1::uc($char);
1954 66         117 my $fc = Elatin1::fc($char);
1955 66 100       117 if ($uc eq $fc) {
1956 12         121 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1957             }
1958             else {
1959 54 50       94 if (CORE::length($fc) == 1) {
1960 54         138 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1961 54         255 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1962             }
1963             else {
1964 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1965 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1966             }
1967             }
1968             }
1969             }
1970 46 50       109 if ($_ ne '') {
1971 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1972             }
1973             }
1974 22         27 my $i = 0;
1975 22         39 my @singleoctet_ignorecase = ();
1976 22         44 for my $ord (0 .. 255) {
1977 5632 100       5963 if (exists $singleoctet_ignorecase{$ord}) {
1978 96         78 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         224  
1979             }
1980             else {
1981 5536         4446 $i++;
1982             }
1983             }
1984 22         55 @singleoctet = ();
1985 22         70 for my $range (@singleoctet_ignorecase) {
1986 3648 100       6523 if (ref $range) {
1987 56 100       48 if (scalar(@{$range}) == 1) {
  56 50       112  
1988 36         43 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         188  
1989             }
1990 20         29 elsif (scalar(@{$range}) == 2) {
1991 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1992             }
1993             else {
1994 20         20 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         27  
  20         112  
1995             }
1996             }
1997             }
1998             }
1999              
2000 236         381 my $not_anchor = '';
2001              
2002 236         671 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2003             }
2004 314 100       679 if (scalar(@multipleoctet) >= 2) {
2005 6         31 return '(?:' . join('|', @multipleoctet) . ')';
2006             }
2007             else {
2008 308         1445 return $multipleoctet[0];
2009             }
2010             }
2011              
2012             #
2013             # Latin-1 open character list for not qr
2014             #
2015             sub charlist_not_qr {
2016              
2017 44     44 0 89 my $modifier = pop @_;
2018 44         110 my @char = @_;
2019              
2020 44         133 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2021 44         104 my @singleoctet = @$singleoctet;
2022 44         68 my @multipleoctet = @$multipleoctet;
2023              
2024             # with /i modifier
2025 44 100       128 if ($modifier =~ m/i/oxms) {
2026 10         17 my %singleoctet_ignorecase = ();
2027 10         18 for (@singleoctet) {
2028 10   66     59 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2029 10         42 for my $ord (hex($1) .. hex($2)) {
2030 30         43 my $char = CORE::chr($ord);
2031 30         48 my $uc = Elatin1::uc($char);
2032 30         51 my $fc = Elatin1::fc($char);
2033 30 50       49 if ($uc eq $fc) {
2034 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2035             }
2036             else {
2037 30 50       45 if (CORE::length($fc) == 1) {
2038 30         72 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2039 30         124 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2040             }
2041             else {
2042 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2043 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2044             }
2045             }
2046             }
2047             }
2048 10 50       29 if ($_ ne '') {
2049 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2050             }
2051             }
2052 10         10 my $i = 0;
2053 10         17 my @singleoctet_ignorecase = ();
2054 10         17 for my $ord (0 .. 255) {
2055 2560 100       2904 if (exists $singleoctet_ignorecase{$ord}) {
2056 60         45 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         103  
2057             }
2058             else {
2059 2500         2126 $i++;
2060             }
2061             }
2062 10         17 @singleoctet = ();
2063 10         26 for my $range (@singleoctet_ignorecase) {
2064 960 100       1817 if (ref $range) {
2065 20 50       17 if (scalar(@{$range}) == 1) {
  20 50       42  
2066 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2067             }
2068 20         31 elsif (scalar(@{$range}) == 2) {
2069 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2070             }
2071             else {
2072 20         25 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         109  
2073             }
2074             }
2075             }
2076             }
2077              
2078             # return character list
2079 44 50       114 if (scalar(@multipleoctet) >= 1) {
2080 0 0       0 if (scalar(@singleoctet) >= 1) {
2081              
2082             # any character other than multiple-octet and single octet character class
2083 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2084             }
2085             else {
2086              
2087             # any character other than multiple-octet character class
2088 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2089             }
2090             }
2091             else {
2092 44 50       90 if (scalar(@singleoctet) >= 1) {
2093              
2094             # any character other than single octet character class
2095 44         290 return '(?:[^' . join('', @singleoctet) . '])';
2096             }
2097             else {
2098              
2099             # any character
2100 0         0 return "(?:$your_char)";
2101             }
2102             }
2103             }
2104              
2105             #
2106             # open file in read mode
2107             #
2108             sub _open_r {
2109 400     400   1008 my(undef,$file) = @_;
2110 400         2751 $file =~ s#\A (\s) #./$1#oxms;
2111 400   33     33789 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2112             open($_[0],"< $file\0");
2113             }
2114              
2115             #
2116             # open file in write mode
2117             #
2118             sub _open_w {
2119 0     0   0 my(undef,$file) = @_;
2120 0         0 $file =~ s#\A (\s) #./$1#oxms;
2121 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2122             open($_[0],"> $file\0");
2123             }
2124              
2125             #
2126             # open file in append mode
2127             #
2128             sub _open_a {
2129 0     0   0 my(undef,$file) = @_;
2130 0         0 $file =~ s#\A (\s) #./$1#oxms;
2131 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2132             open($_[0],">> $file\0");
2133             }
2134              
2135             #
2136             # safe system
2137             #
2138             sub _systemx {
2139              
2140             # P.707 29.2.33. exec
2141             # in Chapter 29: Functions
2142             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2143             #
2144             # Be aware that in older releases of Perl, exec (and system) did not flush
2145             # your output buffer, so you needed to enable command buffering by setting $|
2146             # on one or more filehandles to avoid lost output in the case of exec, or
2147             # misordererd output in the case of system. This situation was largely remedied
2148             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2149              
2150             # P.855 exec
2151             # in Chapter 27: Functions
2152             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2153             #
2154             # In very old release of Perl (before v5.6), exec (and system) did not flush
2155             # your output buffer, so you needed to enable command buffering by setting $|
2156             # on one or more filehandles to avoid lost output with exec or misordered
2157             # output with system.
2158              
2159 200     200   824 $| = 1;
2160              
2161             # P.565 23.1.2. Cleaning Up Your Environment
2162             # in Chapter 23: Security
2163             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2164              
2165             # P.656 Cleaning Up Your Environment
2166             # in Chapter 20: Security
2167             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2168              
2169             # local $ENV{'PATH'} = '.';
2170 200         1798 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2171              
2172             # P.707 29.2.33. exec
2173             # in Chapter 29: Functions
2174             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2175             #
2176             # As we mentioned earlier, exec treats a discrete list of arguments as an
2177             # indication that it should bypass shell processing. However, there is one
2178             # place where you might still get tripped up. The exec call (and system, too)
2179             # will not distinguish between a single scalar argument and an array containing
2180             # only one element.
2181             #
2182             # @args = ("echo surprise"); # just one element in list
2183             # exec @args # still subject to shell escapes
2184             # or die "exec: $!"; # because @args == 1
2185             #
2186             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2187             # first argument as the pathname, which forces the rest of the arguments to be
2188             # interpreted as a list, even if there is only one of them:
2189             #
2190             # exec { $args[0] } @args # safe even with one-argument list
2191             # or die "can't exec @args: $!";
2192              
2193             # P.855 exec
2194             # in Chapter 27: Functions
2195             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2196             #
2197             # As we mentioned earlier, exec treats a discrete list of arguments as a
2198             # directive to bypass shell processing. However, there is one place where
2199             # you might still get tripped up. The exec call (and system, too) cannot
2200             # distinguish between a single scalar argument and an array containing
2201             # only one element.
2202             #
2203             # @args = ("echo surprise"); # just one element in list
2204             # exec @args # still subject to shell escapes
2205             # || die "exec: $!"; # because @args == 1
2206             #
2207             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2208             # argument as the pathname, which forces the rest of the arguments to be
2209             # interpreted as a list, even if there is only one of them:
2210             #
2211             # exec { $args[0] } @args # safe even with one-argument list
2212             # || die "can't exec @args: $!";
2213              
2214 200         378 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         17339482  
2215             }
2216              
2217             #
2218             # Latin-1 order to character (with parameter)
2219             #
2220             sub Elatin1::chr(;$) {
2221              
2222 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2223              
2224 0 0       0 if ($c == 0x00) {
2225 0         0 return "\x00";
2226             }
2227             else {
2228 0         0 my @chr = ();
2229 0         0 while ($c > 0) {
2230 0         0 unshift @chr, ($c % 0x100);
2231 0         0 $c = int($c / 0x100);
2232             }
2233 0         0 return pack 'C*', @chr;
2234             }
2235             }
2236              
2237             #
2238             # Latin-1 order to character (without parameter)
2239             #
2240             sub Elatin1::chr_() {
2241              
2242 0     0 0 0 my $c = $_;
2243              
2244 0 0       0 if ($c == 0x00) {
2245 0         0 return "\x00";
2246             }
2247             else {
2248 0         0 my @chr = ();
2249 0         0 while ($c > 0) {
2250 0         0 unshift @chr, ($c % 0x100);
2251 0         0 $c = int($c / 0x100);
2252             }
2253 0         0 return pack 'C*', @chr;
2254             }
2255             }
2256              
2257             #
2258             # Latin-1 path globbing (with parameter)
2259             #
2260             sub Elatin1::glob($) {
2261              
2262 0 0   0 0 0 if (wantarray) {
2263 0         0 my @glob = _DOS_like_glob(@_);
2264 0         0 for my $glob (@glob) {
2265 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2266             }
2267 0         0 return @glob;
2268             }
2269             else {
2270 0         0 my $glob = _DOS_like_glob(@_);
2271 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2272 0         0 return $glob;
2273             }
2274             }
2275              
2276             #
2277             # Latin-1 path globbing (without parameter)
2278             #
2279             sub Elatin1::glob_() {
2280              
2281 0 0   0 0 0 if (wantarray) {
2282 0         0 my @glob = _DOS_like_glob();
2283 0         0 for my $glob (@glob) {
2284 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2285             }
2286 0         0 return @glob;
2287             }
2288             else {
2289 0         0 my $glob = _DOS_like_glob();
2290 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2291 0         0 return $glob;
2292             }
2293             }
2294              
2295             #
2296             # Latin-1 path globbing via File::DosGlob 1.10
2297             #
2298             # Often I confuse "_dosglob" and "_doglob".
2299             # So, I renamed "_dosglob" to "_DOS_like_glob".
2300             #
2301             my %iter;
2302             my %entries;
2303             sub _DOS_like_glob {
2304              
2305             # context (keyed by second cxix argument provided by core)
2306 0     0   0 my($expr,$cxix) = @_;
2307              
2308             # glob without args defaults to $_
2309 0 0       0 $expr = $_ if not defined $expr;
2310              
2311             # represents the current user's home directory
2312             #
2313             # 7.3. Expanding Tildes in Filenames
2314             # in Chapter 7. File Access
2315             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2316             #
2317             # and File::HomeDir, File::HomeDir::Windows module
2318              
2319             # DOS-like system
2320 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2321 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2322 0         0 { my_home_MSWin32() }oxmse;
2323             }
2324              
2325             # UNIX-like system
2326             else {
2327 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2328 0 0 0     0 { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2329             }
2330              
2331             # assume global context if not provided one
2332 0 0       0 $cxix = '_G_' if not defined $cxix;
2333 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2334              
2335             # if we're just beginning, do it all first
2336 0 0       0 if ($iter{$cxix} == 0) {
2337 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2338             }
2339              
2340             # chuck it all out, quick or slow
2341 0 0       0 if (wantarray) {
2342 0         0 delete $iter{$cxix};
2343 0         0 return @{delete $entries{$cxix}};
  0         0  
2344             }
2345             else {
2346 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2347 0         0 return shift @{$entries{$cxix}};
  0         0  
2348             }
2349             else {
2350             # return undef for EOL
2351 0         0 delete $iter{$cxix};
2352 0         0 delete $entries{$cxix};
2353 0         0 return undef;
2354             }
2355             }
2356             }
2357              
2358             #
2359             # Latin-1 path globbing subroutine
2360             #
2361             sub _do_glob {
2362              
2363 0     0   0 my($cond,@expr) = @_;
2364 0         0 my @glob = ();
2365 0         0 my $fix_drive_relative_paths = 0;
2366              
2367             OUTER:
2368 0         0 for my $expr (@expr) {
2369 0 0       0 next OUTER if not defined $expr;
2370 0 0       0 next OUTER if $expr eq '';
2371              
2372 0         0 my @matched = ();
2373 0         0 my @globdir = ();
2374 0         0 my $head = '.';
2375 0         0 my $pathsep = '/';
2376 0         0 my $tail;
2377              
2378             # if argument is within quotes strip em and do no globbing
2379 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2380 0         0 $expr = $1;
2381 0 0       0 if ($cond eq 'd') {
2382 0 0       0 if (-d $expr) {
2383 0         0 push @glob, $expr;
2384             }
2385             }
2386             else {
2387 0 0       0 if (-e $expr) {
2388 0         0 push @glob, $expr;
2389             }
2390             }
2391 0         0 next OUTER;
2392             }
2393              
2394             # wildcards with a drive prefix such as h:*.pm must be changed
2395             # to h:./*.pm to expand correctly
2396 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2397 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2398 0         0 $fix_drive_relative_paths = 1;
2399             }
2400             }
2401              
2402 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2403 0 0       0 if ($tail eq '') {
2404 0         0 push @glob, $expr;
2405 0         0 next OUTER;
2406             }
2407 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2408 0 0       0 if (@globdir = _do_glob('d', $head)) {
2409 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2410 0         0 next OUTER;
2411             }
2412             }
2413 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2414 0         0 $head .= $pathsep;
2415             }
2416 0         0 $expr = $tail;
2417             }
2418              
2419             # If file component has no wildcards, we can avoid opendir
2420 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2421 0 0       0 if ($head eq '.') {
2422 0         0 $head = '';
2423             }
2424 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2425 0         0 $head .= $pathsep;
2426             }
2427 0         0 $head .= $expr;
2428 0 0       0 if ($cond eq 'd') {
2429 0 0       0 if (-d $head) {
2430 0         0 push @glob, $head;
2431             }
2432             }
2433             else {
2434 0 0       0 if (-e $head) {
2435 0         0 push @glob, $head;
2436             }
2437             }
2438 0         0 next OUTER;
2439             }
2440 0 0       0 opendir(*DIR, $head) or next OUTER;
2441 0         0 my @leaf = readdir DIR;
2442 0         0 closedir DIR;
2443              
2444 0 0       0 if ($head eq '.') {
2445 0         0 $head = '';
2446             }
2447 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2448 0         0 $head .= $pathsep;
2449             }
2450              
2451 0         0 my $pattern = '';
2452 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2453 0         0 my $char = $1;
2454              
2455             # 6.9. Matching Shell Globs as Regular Expressions
2456             # in Chapter 6. Pattern Matching
2457             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2458             # (and so on)
2459              
2460 0 0       0 if ($char eq '*') {
    0          
    0          
2461 0         0 $pattern .= "(?:$your_char)*",
2462             }
2463             elsif ($char eq '?') {
2464 0         0 $pattern .= "(?:$your_char)?", # DOS style
2465             # $pattern .= "(?:$your_char)", # UNIX style
2466             }
2467             elsif ((my $fc = Elatin1::fc($char)) ne $char) {
2468 0         0 $pattern .= $fc;
2469             }
2470             else {
2471 0         0 $pattern .= quotemeta $char;
2472             }
2473             }
2474 0     0   0 my $matchsub = sub { Elatin1::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2475              
2476             # if ($@) {
2477             # print STDERR "$0: $@\n";
2478             # next OUTER;
2479             # }
2480              
2481             INNER:
2482 0         0 for my $leaf (@leaf) {
2483 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2484 0         0 next INNER;
2485             }
2486 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2487 0         0 next INNER;
2488             }
2489              
2490 0 0       0 if (&$matchsub($leaf)) {
2491 0         0 push @matched, "$head$leaf";
2492 0         0 next INNER;
2493             }
2494              
2495             # [DOS compatibility special case]
2496             # Failed, add a trailing dot and try again, but only...
2497              
2498 0 0 0     0 if (Elatin1::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2499             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2500             Elatin1::index($pattern,'\\.') != -1 # pattern has a dot.
2501             ) {
2502 0 0       0 if (&$matchsub("$leaf.")) {
2503 0         0 push @matched, "$head$leaf";
2504 0         0 next INNER;
2505             }
2506             }
2507             }
2508 0 0       0 if (@matched) {
2509 0         0 push @glob, @matched;
2510             }
2511             }
2512 0 0       0 if ($fix_drive_relative_paths) {
2513 0         0 for my $glob (@glob) {
2514 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2515             }
2516             }
2517 0         0 return @glob;
2518             }
2519              
2520             #
2521             # Latin-1 parse line
2522             #
2523             sub _parse_line {
2524              
2525 0     0   0 my($line) = @_;
2526              
2527 0         0 $line .= ' ';
2528 0         0 my @piece = ();
2529 0         0 while ($line =~ /
2530             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2531             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2532             /oxmsg
2533             ) {
2534 0 0       0 push @piece, defined($1) ? $1 : $2;
2535             }
2536 0         0 return @piece;
2537             }
2538              
2539             #
2540             # Latin-1 parse path
2541             #
2542             sub _parse_path {
2543              
2544 0     0   0 my($path,$pathsep) = @_;
2545              
2546 0         0 $path .= '/';
2547 0         0 my @subpath = ();
2548 0         0 while ($path =~ /
2549             ((?: [^\/\\] )+?) [\/\\]
2550             /oxmsg
2551             ) {
2552 0         0 push @subpath, $1;
2553             }
2554              
2555 0         0 my $tail = pop @subpath;
2556 0         0 my $head = join $pathsep, @subpath;
2557 0         0 return $head, $tail;
2558             }
2559              
2560             #
2561             # via File::HomeDir::Windows 1.00
2562             #
2563             sub my_home_MSWin32 {
2564              
2565             # A lot of unix people and unix-derived tools rely on
2566             # the ability to overload HOME. We will support it too
2567             # so that they can replace raw HOME calls with File::HomeDir.
2568 0 0 0 0 0 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2569 0         0 return $ENV{'HOME'};
2570             }
2571              
2572             # Do we have a user profile?
2573             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2574 0         0 return $ENV{'USERPROFILE'};
2575             }
2576              
2577             # Some Windows use something like $ENV{'HOME'}
2578             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2579 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2580             }
2581              
2582 0         0 return undef;
2583             }
2584              
2585             #
2586             # via File::HomeDir::Unix 1.00
2587             #
2588             sub my_home {
2589 0     0 0 0 my $home;
2590              
2591 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2592 0         0 $home = $ENV{'HOME'};
2593             }
2594              
2595             # This is from the original code, but I'm guessing
2596             # it means "login directory" and exists on some Unixes.
2597             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2598 0         0 $home = $ENV{'LOGDIR'};
2599             }
2600              
2601             ### More-desperate methods
2602              
2603             # Light desperation on any (Unixish) platform
2604             else {
2605 0         0 $home = CORE::eval q{ (getpwuid($<))[7] };
2606             }
2607              
2608             # On Unix in general, a non-existant home means "no home"
2609             # For example, "nobody"-like users might use /nonexistant
2610 0 0 0     0 if (defined $home and ! -d($home)) {
2611 0         0 $home = undef;
2612             }
2613 0         0 return $home;
2614             }
2615              
2616             #
2617             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2618             #
2619             sub Elatin1::PREMATCH {
2620 0     0 0 0 return $`;
2621             }
2622              
2623             #
2624             # ${^MATCH}, $MATCH, $& the string that matched
2625             #
2626             sub Elatin1::MATCH {
2627 0     0 0 0 return $&;
2628             }
2629              
2630             #
2631             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2632             #
2633             sub Elatin1::POSTMATCH {
2634 0     0 0 0 return $';
2635             }
2636              
2637             #
2638             # Latin-1 character to order (with parameter)
2639             #
2640             sub Latin1::ord(;$) {
2641              
2642 0 0   0 1 0 local $_ = shift if @_;
2643              
2644 0 0       0 if (/\A ($q_char) /oxms) {
2645 0         0 my @ord = unpack 'C*', $1;
2646 0         0 my $ord = 0;
2647 0         0 while (my $o = shift @ord) {
2648 0         0 $ord = $ord * 0x100 + $o;
2649             }
2650 0         0 return $ord;
2651             }
2652             else {
2653 0         0 return CORE::ord $_;
2654             }
2655             }
2656              
2657             #
2658             # Latin-1 character to order (without parameter)
2659             #
2660             sub Latin1::ord_() {
2661              
2662 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2663 0         0 my @ord = unpack 'C*', $1;
2664 0         0 my $ord = 0;
2665 0         0 while (my $o = shift @ord) {
2666 0         0 $ord = $ord * 0x100 + $o;
2667             }
2668 0         0 return $ord;
2669             }
2670             else {
2671 0         0 return CORE::ord $_;
2672             }
2673             }
2674              
2675             #
2676             # Latin-1 reverse
2677             #
2678             sub Latin1::reverse(@) {
2679              
2680 0 0   0 0 0 if (wantarray) {
2681 0         0 return CORE::reverse @_;
2682             }
2683             else {
2684              
2685             # One of us once cornered Larry in an elevator and asked him what
2686             # problem he was solving with this, but he looked as far off into
2687             # the distance as he could in an elevator and said, "It seemed like
2688             # a good idea at the time."
2689              
2690 0         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2691             }
2692             }
2693              
2694             #
2695             # Latin-1 getc (with parameter, without parameter)
2696             #
2697             sub Latin1::getc(;*@) {
2698              
2699 0     0 0 0 my($package) = caller;
2700 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2701 0 0 0     0 croak 'Too many arguments for Latin1::getc' if @_ and not wantarray;
2702              
2703 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2704 0         0 my $getc = '';
2705 0         0 for my $length ($length[0] .. $length[-1]) {
2706 0         0 $getc .= CORE::getc($fh);
2707 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2708 0 0       0 if ($getc =~ /\A ${Elatin1::dot_s} \z/oxms) {
2709 0 0       0 return wantarray ? ($getc,@_) : $getc;
2710             }
2711             }
2712             }
2713 0 0       0 return wantarray ? ($getc,@_) : $getc;
2714             }
2715              
2716             #
2717             # Latin-1 length by character
2718             #
2719             sub Latin1::length(;$) {
2720              
2721 0 0   0 1 0 local $_ = shift if @_;
2722              
2723 0         0 local @_ = /\G ($q_char) /oxmsg;
2724 0         0 return scalar @_;
2725             }
2726              
2727             #
2728             # Latin-1 substr by character
2729             #
2730             BEGIN {
2731              
2732             # P.232 The lvalue Attribute
2733             # in Chapter 6: Subroutines
2734             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2735              
2736             # P.336 The lvalue Attribute
2737             # in Chapter 7: Subroutines
2738             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2739              
2740             # P.144 8.4 Lvalue subroutines
2741             # in Chapter 8: perlsub: Perl subroutines
2742             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2743              
2744 200 50 0 200 1 112411 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         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2745             # vv----------------------*******
2746             sub Latin1::substr($$;$$) %s {
2747              
2748             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2749              
2750             # If the substring is beyond either end of the string, substr() returns the undefined
2751             # value and produces a warning. When used as an lvalue, specifying a substring that
2752             # is entirely outside the string raises an exception.
2753             # http://perldoc.perl.org/functions/substr.html
2754              
2755             # A return with no argument returns the scalar value undef in scalar context,
2756             # an empty list () in list context, and (naturally) nothing at all in void
2757             # context.
2758              
2759             my $offset = $_[1];
2760             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2761             return;
2762             }
2763              
2764             # substr($string,$offset,$length,$replacement)
2765             if (@_ == 4) {
2766             my(undef,undef,$length,$replacement) = @_;
2767             my $substr = join '', splice(@char, $offset, $length, $replacement);
2768             $_[0] = join '', @char;
2769              
2770             # return $substr; this doesn't work, don't say "return"
2771             $substr;
2772             }
2773              
2774             # substr($string,$offset,$length)
2775             elsif (@_ == 3) {
2776             my(undef,undef,$length) = @_;
2777             my $octet_offset = 0;
2778             my $octet_length = 0;
2779             if ($offset == 0) {
2780             $octet_offset = 0;
2781             }
2782             elsif ($offset > 0) {
2783             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2784             }
2785             else {
2786             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2787             }
2788             if ($length == 0) {
2789             $octet_length = 0;
2790             }
2791             elsif ($length > 0) {
2792             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2793             }
2794             else {
2795             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2796             }
2797             CORE::substr($_[0], $octet_offset, $octet_length);
2798             }
2799              
2800             # substr($string,$offset)
2801             else {
2802             my $octet_offset = 0;
2803             if ($offset == 0) {
2804             $octet_offset = 0;
2805             }
2806             elsif ($offset > 0) {
2807             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2808             }
2809             else {
2810             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2811             }
2812             CORE::substr($_[0], $octet_offset);
2813             }
2814             }
2815             END
2816             }
2817              
2818             #
2819             # Latin-1 index by character
2820             #
2821             sub Latin1::index($$;$) {
2822              
2823 0     0 1 0 my $index;
2824 0 0       0 if (@_ == 3) {
2825 0         0 $index = Elatin1::index($_[0], $_[1], CORE::length(Latin1::substr($_[0], 0, $_[2])));
2826             }
2827             else {
2828 0         0 $index = Elatin1::index($_[0], $_[1]);
2829             }
2830              
2831 0 0       0 if ($index == -1) {
2832 0         0 return -1;
2833             }
2834             else {
2835 0         0 return Latin1::length(CORE::substr $_[0], 0, $index);
2836             }
2837             }
2838              
2839             #
2840             # Latin-1 rindex by character
2841             #
2842             sub Latin1::rindex($$;$) {
2843              
2844 0     0 1 0 my $rindex;
2845 0 0       0 if (@_ == 3) {
2846 0         0 $rindex = Elatin1::rindex($_[0], $_[1], CORE::length(Latin1::substr($_[0], 0, $_[2])));
2847             }
2848             else {
2849 0         0 $rindex = Elatin1::rindex($_[0], $_[1]);
2850             }
2851              
2852 0 0       0 if ($rindex == -1) {
2853 0         0 return -1;
2854             }
2855             else {
2856 0         0 return Latin1::length(CORE::substr $_[0], 0, $rindex);
2857             }
2858             }
2859              
2860             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2861             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2862 200     200   15278 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1762  
  200         352  
  200         13297  
2863              
2864             # ord() to ord() or Latin1::ord()
2865 200     200   11532 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1013  
  200         385  
  200         10352  
2866              
2867             # ord to ord or Latin1::ord_
2868 200     200   11459 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   988  
  200         345  
  200         10166  
2869              
2870             # reverse to reverse or Latin1::reverse
2871 200     200   11064 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   927  
  200         335  
  200         10449  
2872              
2873             # getc to getc or Latin1::getc
2874 200     200   10969 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   1010  
  200         340  
  200         10821  
2875              
2876             # P.1023 Appendix W.9 Multibyte Anchoring
2877             # of ISBN 1-56592-224-7 CJKV Information Processing
2878              
2879             my $anchor = '';
2880              
2881 200     200   11424 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   923  
  200         331  
  200         8619234  
2882              
2883             # regexp of nested parens in qqXX
2884              
2885             # P.340 Matching Nested Constructs with Embedded Code
2886             # in Chapter 7: Perl
2887             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2888              
2889             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2890             [^\\()] |
2891             \( (?{$nest++}) |
2892             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2893             \\ [^c] |
2894             \\c[\x40-\x5F] |
2895             [\x00-\xFF]
2896             }xms;
2897              
2898             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2899             [^\\{}] |
2900             \{ (?{$nest++}) |
2901             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2902             \\ [^c] |
2903             \\c[\x40-\x5F] |
2904             [\x00-\xFF]
2905             }xms;
2906              
2907             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2908             [^\\\[\]] |
2909             \[ (?{$nest++}) |
2910             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2911             \\ [^c] |
2912             \\c[\x40-\x5F] |
2913             [\x00-\xFF]
2914             }xms;
2915              
2916             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2917             [^\\<>] |
2918             \< (?{$nest++}) |
2919             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2920             \\ [^c] |
2921             \\c[\x40-\x5F] |
2922             [\x00-\xFF]
2923             }xms;
2924              
2925             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2926             (?: ::)? (?:
2927             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2928             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2929             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2930             ))
2931             }xms;
2932              
2933             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2934             (?: ::)? (?:
2935             (?>[0-9]+) |
2936             [^a-zA-Z_0-9\[\]] |
2937             ^[A-Z] |
2938             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2939             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2940             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2941             ))
2942             }xms;
2943              
2944             my $qq_substr = qr{(?> Char::substr | Latin1::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2945             }xms;
2946              
2947             # regexp of nested parens in qXX
2948             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2949             [^()] |
2950             \( (?{$nest++}) |
2951             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2952             [\x00-\xFF]
2953             }xms;
2954              
2955             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2956             [^\{\}] |
2957             \{ (?{$nest++}) |
2958             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2959             [\x00-\xFF]
2960             }xms;
2961              
2962             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2963             [^\[\]] |
2964             \[ (?{$nest++}) |
2965             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2966             [\x00-\xFF]
2967             }xms;
2968              
2969             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2970             [^<>] |
2971             \< (?{$nest++}) |
2972             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2973             [\x00-\xFF]
2974             }xms;
2975              
2976             my $matched = '';
2977             my $s_matched = '';
2978              
2979             my $tr_variable = ''; # variable of tr///
2980             my $sub_variable = ''; # variable of s///
2981             my $bind_operator = ''; # =~ or !~
2982              
2983             my @heredoc = (); # here document
2984             my @heredoc_delimiter = ();
2985             my $here_script = ''; # here script
2986              
2987             #
2988             # escape Latin-1 script
2989             #
2990             sub Latin1::escape(;$) {
2991 200 50   200 0 688 local($_) = $_[0] if @_;
2992              
2993             # P.359 The Study Function
2994             # in Chapter 7: Perl
2995             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2996              
2997 200         374 study $_; # Yes, I studied study yesterday.
2998              
2999             # while all script
3000              
3001             # 6.14. Matching from Where the Last Pattern Left Off
3002             # in Chapter 6. Pattern Matching
3003             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3004             # (and so on)
3005              
3006             # one member of Tag-team
3007             #
3008             # P.128 Start of match (or end of previous match): \G
3009             # P.130 Advanced Use of \G with Perl
3010             # in Chapter 3: Overview of Regular Expression Features and Flavors
3011             # P.255 Use leading anchors
3012             # P.256 Expose ^ and \G at the front expressions
3013             # in Chapter 6: Crafting an Efficient Expression
3014             # P.315 "Tag-team" matching with /gc
3015             # in Chapter 7: Perl
3016             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3017              
3018 200         343 my $e_script = '';
3019 200         919 while (not /\G \z/oxgc) { # member
3020 71694         90899 $e_script .= Latin1::escape_token();
3021             }
3022              
3023 200         2297 return $e_script;
3024             }
3025              
3026             #
3027             # escape Latin-1 token of script
3028             #
3029             sub Latin1::escape_token {
3030              
3031             # \n output here document
3032              
3033 71694     71694 0 61689 my $ignore_modules = join('|', qw(
3034             utf8
3035             bytes
3036             charnames
3037             I18N::Japanese
3038             I18N::Collate
3039             I18N::JExt
3040             File::DosGlob
3041             Wild
3042             Wildcard
3043             Japanese
3044             ));
3045              
3046             # another member of Tag-team
3047             #
3048             # P.315 "Tag-team" matching with /gc
3049             # in Chapter 7: Perl
3050             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3051              
3052 71694 100 100     3999271 if (/\G ( \n ) /oxgc) { # another member (and so on)
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3053 12055         10778 my $heredoc = '';
3054 12055 100       21440 if (scalar(@heredoc_delimiter) >= 1) {
3055 150         176 $slash = 'm//';
3056              
3057 150         287 $heredoc = join '', @heredoc;
3058 150         252 @heredoc = ();
3059              
3060             # skip here document
3061 150         262 for my $heredoc_delimiter (@heredoc_delimiter) {
3062 150         1096 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3063             }
3064 150         222 @heredoc_delimiter = ();
3065              
3066 150         176 $here_script = '';
3067             }
3068 12055         36000 return "\n" . $heredoc;
3069             }
3070              
3071             # ignore space, comment
3072 17172         50924 elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3073              
3074             # if (, elsif (, unless (, while (, until (, given (, and when (
3075              
3076             # given, when
3077              
3078             # P.225 The given Statement
3079             # in Chapter 15: Smart Matching and given-when
3080             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3081              
3082             # P.133 The given Statement
3083             # in Chapter 4: Statements and Declarations
3084             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3085              
3086             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3087 1373         1962 $slash = 'm//';
3088 1373         4371 return $1;
3089             }
3090              
3091             # scalar variable ($scalar = ...) =~ tr///;
3092             # scalar variable ($scalar = ...) =~ s///;
3093              
3094             # state
3095              
3096             # P.68 Persistent, Private Variables
3097             # in Chapter 4: Subroutines
3098             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3099              
3100             # P.160 Persistent Lexically Scoped Variables: state
3101             # in Chapter 4: Statements and Declarations
3102             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3103              
3104             # (and so on)
3105              
3106             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3107 85         189 my $e_string = e_string($1);
3108              
3109 85 50       2330 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3110 0         0 $tr_variable = $e_string . e_string($1);
3111 0         0 $bind_operator = $2;
3112 0         0 $slash = 'm//';
3113 0         0 return '';
3114             }
3115             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3116 0         0 $sub_variable = $e_string . e_string($1);
3117 0         0 $bind_operator = $2;
3118 0         0 $slash = 'm//';
3119 0         0 return '';
3120             }
3121             else {
3122 85         127 $slash = 'div';
3123 85         316 return $e_string;
3124             }
3125             }
3126              
3127             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
3128             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3129 4         10 $slash = 'div';
3130 4         19 return q{Elatin1::PREMATCH()};
3131             }
3132              
3133             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
3134             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3135 28         52 $slash = 'div';
3136 28         95 return q{Elatin1::MATCH()};
3137             }
3138              
3139             # $', ${'} --> $', ${'}
3140             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3141 1         2 $slash = 'div';
3142 1         4 return $1;
3143             }
3144              
3145             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
3146             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3147 3         9 $slash = 'div';
3148 3         15 return q{Elatin1::POSTMATCH()};
3149             }
3150              
3151             # scalar variable $scalar =~ tr///;
3152             # scalar variable $scalar =~ s///;
3153             # substr() =~ tr///;
3154             # substr() =~ s///;
3155             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3156 1604         3368 my $scalar = e_string($1);
3157              
3158 1604 100       6981 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3159 1         3 $tr_variable = $scalar;
3160 1         1 $bind_operator = $1;
3161 1         1 $slash = 'm//';
3162 1         4 return '';
3163             }
3164             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3165 61         133 $sub_variable = $scalar;
3166 61         117 $bind_operator = $1;
3167 61         91 $slash = 'm//';
3168 61         239 return '';
3169             }
3170             else {
3171 1542         1739 $slash = 'div';
3172 1542         4397 return $scalar;
3173             }
3174             }
3175              
3176             # end of statement
3177             elsif (/\G ( [,;] ) /oxgc) {
3178 4550         5190 $slash = 'm//';
3179              
3180             # clear tr/// variable
3181 4550         4362 $tr_variable = '';
3182              
3183             # clear s/// variable
3184 4550         3857 $sub_variable = '';
3185              
3186 4550         3697 $bind_operator = '';
3187              
3188 4550         16455 return $1;
3189             }
3190              
3191             # bareword
3192             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3193 0         0 return $1;
3194             }
3195              
3196             # $0 --> $0
3197             elsif (/\G ( \$ 0 ) /oxmsgc) {
3198 2         6 $slash = 'div';
3199 2         9 return $1;
3200             }
3201             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3202 0         0 $slash = 'div';
3203 0         0 return $1;
3204             }
3205              
3206             # $$ --> $$
3207             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3208 1         3 $slash = 'div';
3209 1         6 return $1;
3210             }
3211              
3212             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3213             # $1, $2, $3 --> $1, $2, $3 otherwise
3214             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3215 4         8 $slash = 'div';
3216 4         9 return e_capture($1);
3217             }
3218             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3219 0         0 $slash = 'div';
3220 0         0 return e_capture($1);
3221             }
3222              
3223             # $$foo[ ... ] --> $ $foo->[ ... ]
3224             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3225 0         0 $slash = 'div';
3226 0         0 return e_capture($1.'->'.$2);
3227             }
3228              
3229             # $$foo{ ... } --> $ $foo->{ ... }
3230             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3231 0         0 $slash = 'div';
3232 0         0 return e_capture($1.'->'.$2);
3233             }
3234              
3235             # $$foo
3236             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3237 0         0 $slash = 'div';
3238 0         0 return e_capture($1);
3239             }
3240              
3241             # ${ foo }
3242             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3243 0         0 $slash = 'div';
3244 0         0 return '${' . $1 . '}';
3245             }
3246              
3247             # ${ ... }
3248             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3249 0         0 $slash = 'div';
3250 0         0 return e_capture($1);
3251             }
3252              
3253             # variable or function
3254             # $ @ % & * $ #
3255             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) {
3256 42         60 $slash = 'div';
3257 42         142 return $1;
3258             }
3259             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3260             # $ @ # \ ' " / ? ( ) [ ] < >
3261             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3262 60         152 $slash = 'div';
3263 60         289 return $1;
3264             }
3265              
3266             # while ()
3267             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3268 0         0 return $1;
3269             }
3270              
3271             # while () --- glob
3272              
3273             # avoid "Error: Runtime exception" of perl version 5.005_03
3274              
3275             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3276 0         0 return 'while ($_ = Elatin1::glob("' . $1 . '"))';
3277             }
3278              
3279             # while (glob)
3280             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3281 0         0 return 'while ($_ = Elatin1::glob_)';
3282             }
3283              
3284             # while (glob(WILDCARD))
3285             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3286 0         0 return 'while ($_ = Elatin1::glob';
3287             }
3288              
3289             # doit if, doit unless, doit while, doit until, doit for, doit when
3290 241         513 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         987  
3291              
3292             # subroutines of package Elatin1
3293 19         32 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         79  
3294 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3295 13         14 elsif (/\G \b Latin1::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         26  
3296 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3297 114         125 elsif (/\G \b Latin1::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin1::escape'; }
  114         311  
3298 2         5 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         10  
3299 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::chop'; }
  0         0  
3300 2         4 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
3301 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3302 0         0 elsif (/\G \b Latin1::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin1::index'; }
  0         0  
3303 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::index'; }
  0         0  
3304 2         5 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         6  
3305 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3306 0         0 elsif (/\G \b Latin1::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin1::rindex'; }
  0         0  
3307 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::rindex'; }
  0         0  
3308 1         3 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::lc'; }
  1         5  
3309 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::lcfirst'; }
  0         0  
3310 1         2 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::uc'; }
  1         3  
3311 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::ucfirst'; }
  0         0  
3312 6         9 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::fc'; }
  6         20  
3313              
3314             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3315 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3316 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3317 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3318 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3319 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3320 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3321 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3322              
3323 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3324 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3325 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3326 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3327 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3328 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3329 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3330              
3331             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3332 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3333 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3334 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3335 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3336              
3337 2         4 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         6  
3338 2         4 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3339 36         45 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::chr'; }
  36         118  
3340 2         4 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         7  
3341 8         13 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         31  
3342 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::glob'; }
  0         0  
3343 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::lc_'; }
  0         0  
3344 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::lcfirst_'; }
  0         0  
3345 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::uc_'; }
  0         0  
3346 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::ucfirst_'; }
  0         0  
3347 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::fc_'; }
  0         0  
3348 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3349              
3350 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3351 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3352 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::chr_'; }
  0         0  
3353 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3354 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3355 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::glob_'; }
  0         0  
3356 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3357 8         16 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         31  
3358             # split
3359             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3360 87         148 $slash = 'm//';
3361              
3362 87         128 my $e = '';
3363 87         364 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3364 85         348 $e .= $1;
3365             }
3366              
3367             # end of split
3368 87 100       7543 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin1::split' . $e; }
  2 100       9  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3369              
3370             # split scalar value
3371 1         5 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin1::split' . $e . e_string($1); }
3372              
3373             # split literal space
3374 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin1::split' . $e . qq {qq$1 $2}; }
3375 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3376 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3377 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3378 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3379 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3380 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin1::split' . $e . qq {q$1 $2}; }
3381 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3382 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3383 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3384 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3385 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3386 10         54 elsif (/\G ' [ ] ' /oxgc) { return 'Elatin1::split' . $e . qq {' '}; }
3387 0         0 elsif (/\G " [ ] " /oxgc) { return 'Elatin1::split' . $e . qq {" "}; }
3388              
3389             # split qq//
3390             elsif (/\G \b (qq) \b /oxgc) {
3391 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3392             else {
3393 0         0 while (not /\G \z/oxgc) {
3394 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3395 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3396 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3397 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3398 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3399 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3400 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3401             }
3402 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3403             }
3404             }
3405              
3406             # split qr//
3407             elsif (/\G \b (qr) \b /oxgc) {
3408 12 50       473 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3409             else {
3410 12         57 while (not /\G \z/oxgc) {
3411 12 50       3391 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3412 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3413 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3414 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3415 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3416 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3417 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3418 12         67 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3419             }
3420 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3421             }
3422             }
3423              
3424             # split q//
3425             elsif (/\G \b (q) \b /oxgc) {
3426 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3427             else {
3428 0         0 while (not /\G \z/oxgc) {
3429 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3430 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3431 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3432 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3433 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3434 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3435 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3436             }
3437 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3438             }
3439             }
3440              
3441             # split m//
3442             elsif (/\G \b (m) \b /oxgc) {
3443 18 50       605 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3444             else {
3445 18         71 while (not /\G \z/oxgc) {
3446 18 50       4159 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3447 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3448 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3449 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3450 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3451 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3452 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3453 18         93 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3454             }
3455 0         0 die __FILE__, ": Search pattern not terminated\n";
3456             }
3457             }
3458              
3459             # split ''
3460             elsif (/\G (\') /oxgc) {
3461 0         0 my $q_string = '';
3462 0         0 while (not /\G \z/oxgc) {
3463 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3464 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3465 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3466 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3467             }
3468 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3469             }
3470              
3471             # split ""
3472             elsif (/\G (\") /oxgc) {
3473 0         0 my $qq_string = '';
3474 0         0 while (not /\G \z/oxgc) {
3475 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3476 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3477 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3478 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3479             }
3480 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3481             }
3482              
3483             # split //
3484             elsif (/\G (\/) /oxgc) {
3485 44         80 my $regexp = '';
3486 44         155 while (not /\G \z/oxgc) {
3487 381 50       1592 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3488 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3489 44         203 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3490 337         677 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3491             }
3492 0         0 die __FILE__, ": Search pattern not terminated\n";
3493             }
3494             }
3495              
3496             # tr/// or y///
3497              
3498             # about [cdsrbB]* (/B modifier)
3499             #
3500             # P.559 appendix C
3501             # of ISBN 4-89052-384-7 Programming perl
3502             # (Japanese title is: Perl puroguramingu)
3503              
3504             elsif (/\G \b ( tr | y ) \b /oxgc) {
3505 3         4 my $ope = $1;
3506              
3507             # $1 $2 $3 $4 $5 $6
3508 3 50       39 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3509 0         0 my @tr = ($tr_variable,$2);
3510 0         0 return e_tr(@tr,'',$4,$6);
3511             }
3512             else {
3513 3         5 my $e = '';
3514 3         7 while (not /\G \z/oxgc) {
3515 3 50       200 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3516             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3517 0         0 my @tr = ($tr_variable,$2);
3518 0         0 while (not /\G \z/oxgc) {
3519 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3520 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3521 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3522 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3523 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3524 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3525             }
3526 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3527             }
3528             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3529 0         0 my @tr = ($tr_variable,$2);
3530 0         0 while (not /\G \z/oxgc) {
3531 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3532 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3533 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3534 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3535 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3536 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3537             }
3538 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3539             }
3540             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3541 0         0 my @tr = ($tr_variable,$2);
3542 0         0 while (not /\G \z/oxgc) {
3543 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3544 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3545 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3546 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3547 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3548 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3549             }
3550 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3551             }
3552             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3553 0         0 my @tr = ($tr_variable,$2);
3554 0         0 while (not /\G \z/oxgc) {
3555 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3556 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3557 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3558 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3559 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3560 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3561             }
3562 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3563             }
3564             # $1 $2 $3 $4 $5 $6
3565             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3566 3         10 my @tr = ($tr_variable,$2);
3567 3         7 return e_tr(@tr,'',$4,$6);
3568             }
3569             }
3570 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3571             }
3572             }
3573              
3574             # qq//
3575             elsif (/\G \b (qq) \b /oxgc) {
3576 2130         4050 my $ope = $1;
3577              
3578             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3579 2130 50       3541 if (/\G (\#) /oxgc) { # qq# #
3580 0         0 my $qq_string = '';
3581 0         0 while (not /\G \z/oxgc) {
3582 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3583 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3584 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3585 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3586             }
3587 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3588             }
3589              
3590             else {
3591 2130         2292 my $e = '';
3592 2130         5280 while (not /\G \z/oxgc) {
3593 2130 50       8742 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3594              
3595             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3596             elsif (/\G (\() /oxgc) { # qq ( )
3597 0         0 my $qq_string = '';
3598 0         0 local $nest = 1;
3599 0         0 while (not /\G \z/oxgc) {
3600 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3601 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3602 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3603             elsif (/\G (\)) /oxgc) {
3604 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3605 0         0 else { $qq_string .= $1; }
3606             }
3607 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3608             }
3609 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3610             }
3611              
3612             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3613             elsif (/\G (\{) /oxgc) { # qq { }
3614 2100         2101 my $qq_string = '';
3615 2100         2547 local $nest = 1;
3616 2100         4333 while (not /\G \z/oxgc) {
3617 82644 100       291835 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1480  
    100          
    100          
    50          
3618 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3619 1103         1247 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         1932  
3620             elsif (/\G (\}) /oxgc) {
3621 3203 100       4412 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         4462  
3622 1103         2392 else { $qq_string .= $1; }
3623             }
3624 77616         167103 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3625             }
3626 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3627             }
3628              
3629             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3630             elsif (/\G (\[) /oxgc) { # qq [ ]
3631 0         0 my $qq_string = '';
3632 0         0 local $nest = 1;
3633 0         0 while (not /\G \z/oxgc) {
3634 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3635 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3636 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3637             elsif (/\G (\]) /oxgc) {
3638 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3639 0         0 else { $qq_string .= $1; }
3640             }
3641 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3642             }
3643 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3644             }
3645              
3646             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3647             elsif (/\G (\<) /oxgc) { # qq < >
3648 30         36 my $qq_string = '';
3649 30         52 local $nest = 1;
3650 30         91 while (not /\G \z/oxgc) {
3651 1166 100       4477 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       53  
    50          
    100          
    50          
3652 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3653 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3654             elsif (/\G (\>) /oxgc) {
3655 30 50       65 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         70  
3656 0         0 else { $qq_string .= $1; }
3657             }
3658 1114         2198 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3659             }
3660 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3661             }
3662              
3663             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3664             elsif (/\G (\S) /oxgc) { # qq * *
3665 0         0 my $delimiter = $1;
3666 0         0 my $qq_string = '';
3667 0         0 while (not /\G \z/oxgc) {
3668 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3669 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3670 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3671 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3672             }
3673 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3674             }
3675             }
3676 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3677             }
3678             }
3679              
3680             # qr//
3681             elsif (/\G \b (qr) \b /oxgc) {
3682 0         0 my $ope = $1;
3683 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3684 0         0 return e_qr($ope,$1,$3,$2,$4);
3685             }
3686             else {
3687 0         0 my $e = '';
3688 0         0 while (not /\G \z/oxgc) {
3689 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3690 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3691 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3692 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3693 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3694 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3695 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3696 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3697             }
3698 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3699             }
3700             }
3701              
3702             # qw//
3703             elsif (/\G \b (qw) \b /oxgc) {
3704 16         41 my $ope = $1;
3705 16 50       69 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3706 0         0 return e_qw($ope,$1,$3,$2);
3707             }
3708             else {
3709 16         24 my $e = '';
3710 16         54 while (not /\G \z/oxgc) {
3711 16 50       142 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3712              
3713 16         57 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3714 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3715              
3716 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3717 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3718              
3719 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3720 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3721              
3722 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3723 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3724              
3725 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3726 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3727             }
3728 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3729             }
3730             }
3731              
3732             # qx//
3733             elsif (/\G \b (qx) \b /oxgc) {
3734 0         0 my $ope = $1;
3735 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3736 0         0 return e_qq($ope,$1,$3,$2);
3737             }
3738             else {
3739 0         0 my $e = '';
3740 0         0 while (not /\G \z/oxgc) {
3741 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3742 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3743 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3744 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3745 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3746 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3747 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3748             }
3749 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3750             }
3751             }
3752              
3753             # q//
3754             elsif (/\G \b (q) \b /oxgc) {
3755 245         692 my $ope = $1;
3756              
3757             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3758              
3759             # avoid "Error: Runtime exception" of perl version 5.005_03
3760             # (and so on)
3761              
3762 245 50       784 if (/\G (\#) /oxgc) { # q# #
3763 0         0 my $q_string = '';
3764 0         0 while (not /\G \z/oxgc) {
3765 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3766 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3767 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3768 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3769             }
3770 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3771             }
3772              
3773             else {
3774 245         424 my $e = '';
3775 245         984 while (not /\G \z/oxgc) {
3776 245 50       1798 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3777              
3778             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3779             elsif (/\G (\() /oxgc) { # q ( )
3780 0         0 my $q_string = '';
3781 0         0 local $nest = 1;
3782 0         0 while (not /\G \z/oxgc) {
3783 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3784 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3785 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3786 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3787             elsif (/\G (\)) /oxgc) {
3788 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3789 0         0 else { $q_string .= $1; }
3790             }
3791 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3792             }
3793 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3794             }
3795              
3796             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3797             elsif (/\G (\{) /oxgc) { # q { }
3798 239         411 my $q_string = '';
3799 239         459 local $nest = 1;
3800 239         859 while (not /\G \z/oxgc) {
3801 3637 50       17598 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3802 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3803 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3804 107         117 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         202  
3805             elsif (/\G (\}) /oxgc) {
3806 346 100       838 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         870  
3807 107         209 else { $q_string .= $1; }
3808             }
3809 3184         6096 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3810             }
3811 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3812             }
3813              
3814             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3815             elsif (/\G (\[) /oxgc) { # q [ ]
3816 0         0 my $q_string = '';
3817 0         0 local $nest = 1;
3818 0         0 while (not /\G \z/oxgc) {
3819 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3820 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3821 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3822 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3823             elsif (/\G (\]) /oxgc) {
3824 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3825 0         0 else { $q_string .= $1; }
3826             }
3827 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3828             }
3829 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3830             }
3831              
3832             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3833             elsif (/\G (\<) /oxgc) { # q < >
3834 5         34 my $q_string = '';
3835 5         9 local $nest = 1;
3836 5         70 while (not /\G \z/oxgc) {
3837 88 50       525 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3838 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3839 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3840 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3841             elsif (/\G (\>) /oxgc) {
3842 5 50       26 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         17  
3843 0         0 else { $q_string .= $1; }
3844             }
3845 83         205 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3846             }
3847 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3848             }
3849              
3850             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3851             elsif (/\G (\S) /oxgc) { # q * *
3852 1         2 my $delimiter = $1;
3853 1         2 my $q_string = '';
3854 1         3 while (not /\G \z/oxgc) {
3855 14 50       71 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3856 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3857 1         3 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3858 13         22 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3859             }
3860 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3861             }
3862             }
3863 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3864             }
3865             }
3866              
3867             # m//
3868             elsif (/\G \b (m) \b /oxgc) {
3869 209         441 my $ope = $1;
3870 209 50       2020 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3871 0         0 return e_qr($ope,$1,$3,$2,$4);
3872             }
3873             else {
3874 209         276 my $e = '';
3875 209         622 while (not /\G \z/oxgc) {
3876 209 50       14274 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3877 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3878 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3879 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3880 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3881 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3882 10         40 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3883 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3884 199         697 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3885             }
3886 0         0 die __FILE__, ": Search pattern not terminated\n";
3887             }
3888             }
3889              
3890             # s///
3891              
3892             # about [cegimosxpradlunbB]* (/cg modifier)
3893             #
3894             # P.67 Pattern-Matching Operators
3895             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3896              
3897             elsif (/\G \b (s) \b /oxgc) {
3898 97         269 my $ope = $1;
3899              
3900             # $1 $2 $3 $4 $5 $6
3901 97 100       2293 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3902 1         10 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3903             }
3904             else {
3905 96         188 my $e = '';
3906 96         383 while (not /\G \z/oxgc) {
3907 96 50       13934 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3908             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3909 0         0 my @s = ($1,$2,$3);
3910 0         0 while (not /\G \z/oxgc) {
3911 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3912             # $1 $2 $3 $4
3913 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3916 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3917 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3918 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3919 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3920 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3921 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3922             }
3923 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3924             }
3925             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3926 0         0 my @s = ($1,$2,$3);
3927 0         0 while (not /\G \z/oxgc) {
3928 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3929             # $1 $2 $3 $4
3930 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939             }
3940 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3941             }
3942             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3943 0         0 my @s = ($1,$2,$3);
3944 0         0 while (not /\G \z/oxgc) {
3945 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3946             # $1 $2 $3 $4
3947 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954             }
3955 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3956             }
3957             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3958 0         0 my @s = ($1,$2,$3);
3959 0         0 while (not /\G \z/oxgc) {
3960 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3961             # $1 $2 $3 $4
3962 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971             }
3972 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3973             }
3974             # $1 $2 $3 $4 $5 $6
3975             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3976 21         97 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3977             }
3978             # $1 $2 $3 $4 $5 $6
3979             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3980 0         0 return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3981             }
3982             # $1 $2 $3 $4 $5 $6
3983             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3984 0         0 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3985             }
3986             # $1 $2 $3 $4 $5 $6
3987             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3988 75         346 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3989             }
3990             }
3991 0         0 die __FILE__, ": Substitution pattern not terminated\n";
3992             }
3993             }
3994              
3995             # require ignore module
3996 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3997 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3998 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3999              
4000             # use strict; --> use strict; no strict qw(refs);
4001 36         384 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4002 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4003 0         0 elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4004              
4005             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4006             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4007 2 50 33     26 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4008 0         0 return "use $1; no strict qw(refs);";
4009             }
4010             else {
4011 2         11 return "use $1;";
4012             }
4013             }
4014             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4015 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4016 0         0 return "use $1; no strict qw(refs);";
4017             }
4018             else {
4019 0         0 return "use $1;";
4020             }
4021             }
4022              
4023             # ignore use module
4024 2         16 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4025 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4026 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4027              
4028             # ignore no module
4029 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4030 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4031 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4032              
4033             # use else
4034 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4035              
4036             # use else
4037 2         10 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4038              
4039             # ''
4040             elsif (/\G (?
4041 841         1505 my $q_string = '';
4042 841         2328 while (not /\G \z/oxgc) {
4043 8209 100       41345 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       14  
    100          
    50          
4044 48         104 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4045 841         1943 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4046 7316         15915 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4047             }
4048 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4049             }
4050              
4051             # ""
4052             elsif (/\G (\") /oxgc) {
4053 1723         2764 my $qq_string = '';
4054 1723         4484 while (not /\G \z/oxgc) {
4055 34204 100       105408 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       176  
    100          
    50          
4056 12         19 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4057 1723         3988 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4058 32402         64196 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4059             }
4060 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4061             }
4062              
4063             # ``
4064             elsif (/\G (\`) /oxgc) {
4065 1         2 my $qx_string = '';
4066 1         3 while (not /\G \z/oxgc) {
4067 19 50       87 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4068 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4069 1         2 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4070 18         31 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4071             }
4072 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4073             }
4074              
4075             # // --- not divide operator (num / num), not defined-or
4076             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4077 452         770 my $regexp = '';
4078 452         1388 while (not /\G \z/oxgc) {
4079 4490 50       17333 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4080 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4081 452         1368 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4082 4038         9084 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4083             }
4084 0         0 die __FILE__, ": Search pattern not terminated\n";
4085             }
4086              
4087             # ?? --- not conditional operator (condition ? then : else)
4088             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4089 0         0 my $regexp = '';
4090 0         0 while (not /\G \z/oxgc) {
4091 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4092 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4093 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4094 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4095             }
4096 0         0 die __FILE__, ": Search pattern not terminated\n";
4097             }
4098              
4099             # <<>> (a safer ARGV)
4100 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4101              
4102             # << (bit shift) --- not here document
4103 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4104              
4105             # <<'HEREDOC'
4106             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4107 72         114 $slash = 'm//';
4108 72         151 my $here_quote = $1;
4109 72         108 my $delimiter = $2;
4110              
4111             # get here document
4112 72 50       147 if ($here_script eq '') {
4113 72         398 $here_script = CORE::substr $_, pos $_;
4114 72         397 $here_script =~ s/.*?\n//oxm;
4115             }
4116 72 50       645 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4117 72         251 push @heredoc, $1 . qq{\n$delimiter\n};
4118 72         200 push @heredoc_delimiter, $delimiter;
4119             }
4120             else {
4121 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4122             }
4123 72         312 return $here_quote;
4124             }
4125              
4126             # <<\HEREDOC
4127              
4128             # P.66 2.6.6. "Here" Documents
4129             # in Chapter 2: Bits and Pieces
4130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4131              
4132             # P.73 "Here" Documents
4133             # in Chapter 2: Bits and Pieces
4134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4135              
4136             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4137 0         0 $slash = 'm//';
4138 0         0 my $here_quote = $1;
4139 0         0 my $delimiter = $2;
4140              
4141             # get here document
4142 0 0       0 if ($here_script eq '') {
4143 0         0 $here_script = CORE::substr $_, pos $_;
4144 0         0 $here_script =~ s/.*?\n//oxm;
4145             }
4146 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4147 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4148 0         0 push @heredoc_delimiter, $delimiter;
4149             }
4150             else {
4151 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4152             }
4153 0         0 return $here_quote;
4154             }
4155              
4156             # <<"HEREDOC"
4157             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4158 36         72 $slash = 'm//';
4159 36         77 my $here_quote = $1;
4160 36         550 my $delimiter = $2;
4161              
4162             # get here document
4163 36 50       101 if ($here_script eq '') {
4164 36         261 $here_script = CORE::substr $_, pos $_;
4165 36         205 $here_script =~ s/.*?\n//oxm;
4166             }
4167 36 50       820 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4168 36         106 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4169 36         122 push @heredoc_delimiter, $delimiter;
4170             }
4171             else {
4172 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4173             }
4174 36         158 return $here_quote;
4175             }
4176              
4177             # <
4178             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4179 42         75 $slash = 'm//';
4180 42         78 my $here_quote = $1;
4181 42         73 my $delimiter = $2;
4182              
4183             # get here document
4184 42 50       111 if ($here_script eq '') {
4185 42         303 $here_script = CORE::substr $_, pos $_;
4186 42         306 $here_script =~ s/.*?\n//oxm;
4187             }
4188 42 50       609 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4189 42         114 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4190 42         97 push @heredoc_delimiter, $delimiter;
4191             }
4192             else {
4193 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4194             }
4195 42         169 return $here_quote;
4196             }
4197              
4198             # <<`HEREDOC`
4199             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4200 0         0 $slash = 'm//';
4201 0         0 my $here_quote = $1;
4202 0         0 my $delimiter = $2;
4203              
4204             # get here document
4205 0 0       0 if ($here_script eq '') {
4206 0         0 $here_script = CORE::substr $_, pos $_;
4207 0         0 $here_script =~ s/.*?\n//oxm;
4208             }
4209 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4210 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4211 0         0 push @heredoc_delimiter, $delimiter;
4212             }
4213             else {
4214 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4215             }
4216 0         0 return $here_quote;
4217             }
4218              
4219             # <<= <=> <= < operator
4220             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4221 11         62 return $1;
4222             }
4223              
4224             #
4225             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4226 0         0 return $1;
4227             }
4228              
4229             # --- glob
4230              
4231             # avoid "Error: Runtime exception" of perl version 5.005_03
4232              
4233             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4234 0         0 return 'Elatin1::glob("' . $1 . '")';
4235             }
4236              
4237             # __DATA__
4238 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4239              
4240             # __END__
4241 200         1533 elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4242              
4243             # \cD Control-D
4244              
4245             # P.68 2.6.8. Other Literal Tokens
4246             # in Chapter 2: Bits and Pieces
4247             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4248              
4249             # P.76 Other Literal Tokens
4250             # in Chapter 2: Bits and Pieces
4251             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4252              
4253 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4254              
4255             # \cZ Control-Z
4256 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4257              
4258             # any operator before div
4259             elsif (/\G (
4260             -- | \+\+ |
4261             [\)\}\]]
4262              
4263 4824         6105 ) /oxgc) { $slash = 'div'; return $1; }
  4824         22227  
4264              
4265             # yada-yada or triple-dot operator
4266             elsif (/\G (
4267             \.\.\.
4268              
4269 7         14 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         35  
4270              
4271             # any operator before m//
4272              
4273             # //, //= (defined-or)
4274              
4275             # P.164 Logical Operators
4276             # in Chapter 10: More Control Structures
4277             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4278              
4279             # P.119 C-Style Logical (Short-Circuit) Operators
4280             # in Chapter 3: Unary and Binary Operators
4281             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4282              
4283             # (and so on)
4284              
4285             # ~~
4286              
4287             # P.221 The Smart Match Operator
4288             # in Chapter 15: Smart Matching and given-when
4289             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4290              
4291             # P.112 Smartmatch Operator
4292             # in Chapter 3: Unary and Binary Operators
4293             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4294              
4295             # (and so on)
4296              
4297             elsif (/\G ((?>
4298              
4299             !~~ | !~ | != | ! |
4300             %= | % |
4301             &&= | && | &= | &\.= | &\. | & |
4302             -= | -> | - |
4303             :(?>\s*)= |
4304             : |
4305             <<>> |
4306             <<= | <=> | <= | < |
4307             == | => | =~ | = |
4308             >>= | >> | >= | > |
4309             \*\*= | \*\* | \*= | \* |
4310             \+= | \+ |
4311             \.\. | \.= | \. |
4312             \/\/= | \/\/ |
4313             \/= | \/ |
4314             \? |
4315             \\ |
4316             \^= | \^\.= | \^\. | \^ |
4317             \b x= |
4318             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4319             ~~ | ~\. | ~ |
4320             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4321             \b(?: print )\b |
4322              
4323             [,;\(\{\[]
4324              
4325 8473         10475 )) /oxgc) { $slash = 'm//'; return $1; }
  8473         38582  
4326              
4327             # other any character
4328 14740         17032 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14740         65147  
4329              
4330             # system error
4331             else {
4332 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4333             }
4334             }
4335              
4336             # escape Latin-1 string
4337             sub e_string {
4338 1718     1718 0 3288 my($string) = @_;
4339 1718         1909 my $e_string = '';
4340              
4341 1718         2152 local $slash = 'm//';
4342              
4343             # P.1024 Appendix W.10 Multibyte Processing
4344             # of ISBN 1-56592-224-7 CJKV Information Processing
4345             # (and so on)
4346              
4347 1718         16468 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4348              
4349             # without { ... }
4350 1718 100 66     7992 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4351 1701 50       3776 if ($string !~ /<
4352 1701         4162 return $string;
4353             }
4354             }
4355              
4356             E_STRING_LOOP:
4357 17         59 while ($string !~ /\G \z/oxgc) {
4358 190 50       13544 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4359             }
4360              
4361             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin1::PREMATCH()]}
4362 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4363 0         0 $e_string .= q{Elatin1::PREMATCH()};
4364 0         0 $slash = 'div';
4365             }
4366              
4367             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin1::MATCH()]}
4368             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4369 0         0 $e_string .= q{Elatin1::MATCH()};
4370 0         0 $slash = 'div';
4371             }
4372              
4373             # $', ${'} --> $', ${'}
4374             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4375 0         0 $e_string .= $1;
4376 0         0 $slash = 'div';
4377             }
4378              
4379             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin1::POSTMATCH()]}
4380             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4381 0         0 $e_string .= q{Elatin1::POSTMATCH()};
4382 0         0 $slash = 'div';
4383             }
4384              
4385             # bareword
4386             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4387 0         0 $e_string .= $1;
4388 0         0 $slash = 'div';
4389             }
4390              
4391             # $0 --> $0
4392             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4393 0         0 $e_string .= $1;
4394 0         0 $slash = 'div';
4395             }
4396             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4397 0         0 $e_string .= $1;
4398 0         0 $slash = 'div';
4399             }
4400              
4401             # $$ --> $$
4402             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4403 0         0 $e_string .= $1;
4404 0         0 $slash = 'div';
4405             }
4406              
4407             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4408             # $1, $2, $3 --> $1, $2, $3 otherwise
4409             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4410 0         0 $e_string .= e_capture($1);
4411 0         0 $slash = 'div';
4412             }
4413             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4414 0         0 $e_string .= e_capture($1);
4415 0         0 $slash = 'div';
4416             }
4417              
4418             # $$foo[ ... ] --> $ $foo->[ ... ]
4419             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4420 0         0 $e_string .= e_capture($1.'->'.$2);
4421 0         0 $slash = 'div';
4422             }
4423              
4424             # $$foo{ ... } --> $ $foo->{ ... }
4425             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4426 0         0 $e_string .= e_capture($1.'->'.$2);
4427 0         0 $slash = 'div';
4428             }
4429              
4430             # $$foo
4431             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4432 0         0 $e_string .= e_capture($1);
4433 0         0 $slash = 'div';
4434             }
4435              
4436             # ${ foo }
4437             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4438 0         0 $e_string .= '${' . $1 . '}';
4439 0         0 $slash = 'div';
4440             }
4441              
4442             # ${ ... }
4443             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4444 3         10 $e_string .= e_capture($1);
4445 3         14 $slash = 'div';
4446             }
4447              
4448             # variable or function
4449             # $ @ % & * $ #
4450             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) {
4451 7         16 $e_string .= $1;
4452 7         25 $slash = 'div';
4453             }
4454             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4455             # $ @ # \ ' " / ? ( ) [ ] < >
4456             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4457 0         0 $e_string .= $1;
4458 0         0 $slash = 'div';
4459             }
4460              
4461             # subroutines of package Elatin1
4462 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4463 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4464 0         0 elsif ($string =~ /\G \b Latin1::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4465 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4466 0         0 elsif ($string =~ /\G \b Latin1::eval \b /oxgc) { $e_string .= 'eval Latin1::escape'; $slash = 'm//'; }
  0         0  
4467 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4468 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin1::chop'; $slash = 'm//'; }
  0         0  
4469 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4470 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4471 0         0 elsif ($string =~ /\G \b Latin1::index \b /oxgc) { $e_string .= 'Latin1::index'; $slash = 'm//'; }
  0         0  
4472 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin1::index'; $slash = 'm//'; }
  0         0  
4473 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4474 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4475 0         0 elsif ($string =~ /\G \b Latin1::rindex \b /oxgc) { $e_string .= 'Latin1::rindex'; $slash = 'm//'; }
  0         0  
4476 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin1::rindex'; $slash = 'm//'; }
  0         0  
4477 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::lc'; $slash = 'm//'; }
  0         0  
4478 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::lcfirst'; $slash = 'm//'; }
  0         0  
4479 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::uc'; $slash = 'm//'; }
  0         0  
4480 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::ucfirst'; $slash = 'm//'; }
  0         0  
4481 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::fc'; $slash = 'm//'; }
  0         0  
4482              
4483             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4484 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4485 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4486 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4487 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4488 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4489 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4490 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4491              
4492 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4493 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4494 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4495 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4496 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4497 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4498 0         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         0  
4499              
4500             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4501 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4502 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4503 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4504 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4505              
4506 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4507 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4508 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::chr'; $slash = 'm//'; }
  0         0  
4509 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4510 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4511 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::glob'; $slash = 'm//'; }
  0         0  
4512 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin1::lc_'; $slash = 'm//'; }
  0         0  
4513 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin1::lcfirst_'; $slash = 'm//'; }
  0         0  
4514 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin1::uc_'; $slash = 'm//'; }
  0         0  
4515 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin1::ucfirst_'; $slash = 'm//'; }
  0         0  
4516 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin1::fc_'; $slash = 'm//'; }
  0         0  
4517 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4518              
4519 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4520 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin1::chr_'; $slash = 'm//'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4524 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin1::glob_'; $slash = 'm//'; }
  0         0  
4525 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4526 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4527             # split
4528             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4529 0         0 $slash = 'm//';
4530              
4531 0         0 my $e = '';
4532 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4533 0         0 $e .= $1;
4534             }
4535              
4536             # end of split
4537 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin1::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          
    0          
4538              
4539             # split scalar value
4540 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin1::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4541              
4542             # split literal space
4543 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4544 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4545 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4546 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4547 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4548 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4549 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4550 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4551 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4552 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4553 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4554 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4555 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4556 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4557              
4558             # split qq//
4559             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4560 0 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  
  0         0  
4561             else {
4562 0         0 while ($string !~ /\G \z/oxgc) {
4563 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4564 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4565 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4566 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4567 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4568 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4569 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0         0  
4570             }
4571 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4572             }
4573             }
4574              
4575             # split qr//
4576             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4577 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0         0  
  0         0  
4578             else {
4579 0         0 while ($string !~ /\G \z/oxgc) {
4580 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4581 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4582 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4583 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4584 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4585 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4586 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0         0  
4587 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0         0  
4588             }
4589 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4590             }
4591             }
4592              
4593             # split q//
4594             elsif ($string =~ /\G \b (q) \b /oxgc) {
4595 0 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  
  0         0  
4596             else {
4597 0         0 while ($string !~ /\G \z/oxgc) {
4598 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4599 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4600 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4601 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4602 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4603 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0         0  
4604 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
  0         0  
4605             }
4606 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4607             }
4608             }
4609              
4610             # split m//
4611             elsif ($string =~ /\G \b (m) \b /oxgc) {
4612 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0         0  
  0         0  
4613             else {
4614 0         0 while ($string !~ /\G \z/oxgc) {
4615 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4616 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4617 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4618 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4619 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4620 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4621 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0         0  
4622 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0         0  
4623             }
4624 0         0 die __FILE__, ": Search pattern not terminated\n";
4625             }
4626             }
4627              
4628             # split ''
4629             elsif ($string =~ /\G (\') /oxgc) {
4630 0         0 my $q_string = '';
4631 0         0 while ($string !~ /\G \z/oxgc) {
4632 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4633 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4634 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4635 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4636             }
4637 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4638             }
4639              
4640             # split ""
4641             elsif ($string =~ /\G (\") /oxgc) {
4642 0         0 my $qq_string = '';
4643 0         0 while ($string !~ /\G \z/oxgc) {
4644 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4645 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4646 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4647 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4648             }
4649 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4650             }
4651              
4652             # split //
4653             elsif ($string =~ /\G (\/) /oxgc) {
4654 0         0 my $regexp = '';
4655 0         0 while ($string !~ /\G \z/oxgc) {
4656 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4657 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4658 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4659 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4660             }
4661 0         0 die __FILE__, ": Search pattern not terminated\n";
4662             }
4663             }
4664              
4665             # qq//
4666             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4667 0         0 my $ope = $1;
4668 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4669 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4670             }
4671             else {
4672 0         0 my $e = '';
4673 0         0 while ($string !~ /\G \z/oxgc) {
4674 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4675 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4676 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4677 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4678 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4679 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0         0  
4680             }
4681 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4682             }
4683             }
4684              
4685             # qx//
4686             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4687 0         0 my $ope = $1;
4688 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4689 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4690             }
4691             else {
4692 0         0 my $e = '';
4693 0         0 while ($string !~ /\G \z/oxgc) {
4694 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4695 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4696 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4697 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4698 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4699 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4700 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0         0  
4701             }
4702 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4703             }
4704             }
4705              
4706             # q//
4707             elsif ($string =~ /\G \b (q) \b /oxgc) {
4708 0         0 my $ope = $1;
4709 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4710 0         0 $e_string .= e_q($ope,$1,$3,$2);
4711             }
4712             else {
4713 0         0 my $e = '';
4714 0         0 while ($string !~ /\G \z/oxgc) {
4715 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4716 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4717 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4718 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4719 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4720 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0         0  
4721             }
4722 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4723             }
4724             }
4725              
4726             # ''
4727 0         0 elsif ($string =~ /\G (?
4728              
4729             # ""
4730 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4731              
4732             # ``
4733 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4734              
4735             # <<>> (a safer ARGV)
4736 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4737              
4738             # <<= <=> <= < operator
4739 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4740              
4741             #
4742 0         0 elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4743              
4744             # --- glob
4745             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4746 0         0 $e_string .= 'Elatin1::glob("' . $1 . '")';
4747             }
4748              
4749             # << (bit shift) --- not here document
4750 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4751              
4752             # <<'HEREDOC'
4753             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4754 0         0 $slash = 'm//';
4755 0         0 my $here_quote = $1;
4756 0         0 my $delimiter = $2;
4757              
4758             # get here document
4759 0 0       0 if ($here_script eq '') {
4760 0         0 $here_script = CORE::substr $_, pos $_;
4761 0         0 $here_script =~ s/.*?\n//oxm;
4762             }
4763 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4764 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4765 0         0 push @heredoc_delimiter, $delimiter;
4766             }
4767             else {
4768 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4769             }
4770 0         0 $e_string .= $here_quote;
4771             }
4772              
4773             # <<\HEREDOC
4774             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4775 0         0 $slash = 'm//';
4776 0         0 my $here_quote = $1;
4777 0         0 my $delimiter = $2;
4778              
4779             # get here document
4780 0 0       0 if ($here_script eq '') {
4781 0         0 $here_script = CORE::substr $_, pos $_;
4782 0         0 $here_script =~ s/.*?\n//oxm;
4783             }
4784 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4785 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4786 0         0 push @heredoc_delimiter, $delimiter;
4787             }
4788             else {
4789 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4790             }
4791 0         0 $e_string .= $here_quote;
4792             }
4793              
4794             # <<"HEREDOC"
4795             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4796 0         0 $slash = 'm//';
4797 0         0 my $here_quote = $1;
4798 0         0 my $delimiter = $2;
4799              
4800             # get here document
4801 0 0       0 if ($here_script eq '') {
4802 0         0 $here_script = CORE::substr $_, pos $_;
4803 0         0 $here_script =~ s/.*?\n//oxm;
4804             }
4805 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4806 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4807 0         0 push @heredoc_delimiter, $delimiter;
4808             }
4809             else {
4810 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4811             }
4812 0         0 $e_string .= $here_quote;
4813             }
4814              
4815             # <
4816             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4817 0         0 $slash = 'm//';
4818 0         0 my $here_quote = $1;
4819 0         0 my $delimiter = $2;
4820              
4821             # get here document
4822 0 0       0 if ($here_script eq '') {
4823 0         0 $here_script = CORE::substr $_, pos $_;
4824 0         0 $here_script =~ s/.*?\n//oxm;
4825             }
4826 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4827 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4828 0         0 push @heredoc_delimiter, $delimiter;
4829             }
4830             else {
4831 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4832             }
4833 0         0 $e_string .= $here_quote;
4834             }
4835              
4836             # <<`HEREDOC`
4837             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4838 0         0 $slash = 'm//';
4839 0         0 my $here_quote = $1;
4840 0         0 my $delimiter = $2;
4841              
4842             # get here document
4843 0 0       0 if ($here_script eq '') {
4844 0         0 $here_script = CORE::substr $_, pos $_;
4845 0         0 $here_script =~ s/.*?\n//oxm;
4846             }
4847 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4848 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4849 0         0 push @heredoc_delimiter, $delimiter;
4850             }
4851             else {
4852 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4853             }
4854 0         0 $e_string .= $here_quote;
4855             }
4856              
4857             # any operator before div
4858             elsif ($string =~ /\G (
4859             -- | \+\+ |
4860             [\)\}\]]
4861              
4862 18         27 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         58  
4863              
4864             # yada-yada or triple-dot operator
4865             elsif ($string =~ /\G (
4866             \.\.\.
4867              
4868 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         0  
4869              
4870             # any operator before m//
4871             elsif ($string =~ /\G ((?>
4872              
4873             !~~ | !~ | != | ! |
4874             %= | % |
4875             &&= | && | &= | &\.= | &\. | & |
4876             -= | -> | - |
4877             :(?>\s*)= |
4878             : |
4879             <<>> |
4880             <<= | <=> | <= | < |
4881             == | => | =~ | = |
4882             >>= | >> | >= | > |
4883             \*\*= | \*\* | \*= | \* |
4884             \+= | \+ |
4885             \.\. | \.= | \. |
4886             \/\/= | \/\/ |
4887             \/= | \/ |
4888             \? |
4889             \\ |
4890             \^= | \^\.= | \^\. | \^ |
4891             \b x= |
4892             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4893             ~~ | ~\. | ~ |
4894             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4895             \b(?: print )\b |
4896              
4897             [,;\(\{\[]
4898              
4899 31         45 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         124  
4900              
4901             # other any character
4902 131         342 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4903              
4904             # system error
4905             else {
4906 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4907             }
4908             }
4909              
4910 17         69 return $e_string;
4911             }
4912              
4913             #
4914             # character class
4915             #
4916             sub character_class {
4917 1914     1914 0 2540 my($char,$modifier) = @_;
4918              
4919 1914 100       3629 if ($char eq '.') {
4920 52 100       114 if ($modifier =~ /s/) {
4921 17         40 return '${Elatin1::dot_s}';
4922             }
4923             else {
4924 35         104 return '${Elatin1::dot}';
4925             }
4926             }
4927             else {
4928 1862         2899 return Elatin1::classic_character_class($char);
4929             }
4930             }
4931              
4932             #
4933             # escape capture ($1, $2, $3, ...)
4934             #
4935             sub e_capture {
4936              
4937 212     212 0 852 return join '', '${', $_[0], '}';
4938             }
4939              
4940             #
4941             # escape transliteration (tr/// or y///)
4942             #
4943             sub e_tr {
4944 3     3 0 6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4945 3         3 my $e_tr = '';
4946 3   50     4 $modifier ||= '';
4947              
4948 3         3 $slash = 'div';
4949              
4950             # quote character class 1
4951 3         4 $charclass = q_tr($charclass);
4952              
4953             # quote character class 2
4954 3         4 $charclass2 = q_tr($charclass2);
4955              
4956             # /b /B modifier
4957 3 50       6 if ($modifier =~ tr/bB//d) {
4958 0 0       0 if ($variable eq '') {
4959 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4960             }
4961             else {
4962 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4963             }
4964             }
4965             else {
4966 3 100       5 if ($variable eq '') {
4967 2         7 $e_tr = qq{Elatin1::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4968             }
4969             else {
4970 1         4 $e_tr = qq{Elatin1::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4971             }
4972             }
4973              
4974             # clear tr/// variable
4975 3         3 $tr_variable = '';
4976 3         3 $bind_operator = '';
4977              
4978 3         13 return $e_tr;
4979             }
4980              
4981             #
4982             # quote for escape transliteration (tr/// or y///)
4983             #
4984             sub q_tr {
4985 6     6 0 5 my($charclass) = @_;
4986              
4987             # quote character class
4988 6 50       9 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4989 6         8 return e_q('', "'", "'", $charclass); # --> q' '
4990             }
4991             elsif ($charclass !~ /\//oxms) {
4992 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
4993             }
4994             elsif ($charclass !~ /\#/oxms) {
4995 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
4996             }
4997             elsif ($charclass !~ /[\<\>]/oxms) {
4998 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
4999             }
5000             elsif ($charclass !~ /[\(\)]/oxms) {
5001 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
5002             }
5003             elsif ($charclass !~ /[\{\}]/oxms) {
5004 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5005             }
5006             else {
5007 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5008 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5009 0         0 return e_q('q', $char, $char, $charclass);
5010             }
5011             }
5012             }
5013              
5014 0         0 return e_q('q', '{', '}', $charclass);
5015             }
5016              
5017             #
5018             # escape q string (q//, '')
5019             #
5020             sub e_q {
5021 1092     1092 0 2158 my($ope,$delimiter,$end_delimiter,$string) = @_;
5022              
5023 1092         1417 $slash = 'div';
5024              
5025 1092         6035 return join '', $ope, $delimiter, $string, $end_delimiter;
5026             }
5027              
5028             #
5029             # escape qq string (qq//, "", qx//, ``)
5030             #
5031             sub e_qq {
5032 3935     3935 0 7162 my($ope,$delimiter,$end_delimiter,$string) = @_;
5033              
5034 3935         4238 $slash = 'div';
5035              
5036 3935         3570 my $left_e = 0;
5037 3935         3191 my $right_e = 0;
5038              
5039             # split regexp
5040 3935         156984 my @char = $string =~ /\G((?>
5041             [^\\\$] |
5042             \\x\{ (?>[0-9A-Fa-f]+) \} |
5043             \\o\{ (?>[0-7]+) \} |
5044             \\N\{ (?>[^0-9\}][^\}]*) \} |
5045             \\ $q_char |
5046             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5047             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5048             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5049             \$ (?>\s* [0-9]+) |
5050             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5051             \$ \$ (?![\w\{]) |
5052             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5053             $q_char
5054             ))/oxmsg;
5055              
5056 3935         15157 for (my $i=0; $i <= $#char; $i++) {
5057              
5058             # "\L\u" --> "\u\L"
5059 111780 50 33     462827 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5060 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5061             }
5062              
5063             # "\U\l" --> "\l\U"
5064             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5065 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5066             }
5067              
5068             # octal escape sequence
5069             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5070 1         5 $char[$i] = Elatin1::octchr($1);
5071             }
5072              
5073             # hexadecimal escape sequence
5074             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5075 1         3 $char[$i] = Elatin1::hexchr($1);
5076             }
5077              
5078             # \N{CHARNAME} --> N{CHARNAME}
5079             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5080 0         0 $char[$i] = $1;
5081             }
5082              
5083 111780 100       1272595 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5084             }
5085              
5086             # \F
5087             #
5088             # P.69 Table 2-6. Translation escapes
5089             # in Chapter 2: Bits and Pieces
5090             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5091             # (and so on)
5092              
5093             # \u \l \U \L \F \Q \E
5094 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5095 484 50       1194 if ($right_e < $left_e) {
5096 0         0 $char[$i] = '\\' . $char[$i];
5097             }
5098             }
5099             elsif ($char[$i] eq '\u') {
5100              
5101             # "STRING @{[ LIST EXPR ]} MORE STRING"
5102              
5103             # P.257 Other Tricks You Can Do with Hard References
5104             # in Chapter 8: References
5105             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5106              
5107             # P.353 Other Tricks You Can Do with Hard References
5108             # in Chapter 8: References
5109             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5110              
5111             # (and so on)
5112              
5113 0         0 $char[$i] = '@{[Elatin1::ucfirst qq<';
5114 0         0 $left_e++;
5115             }
5116             elsif ($char[$i] eq '\l') {
5117 0         0 $char[$i] = '@{[Elatin1::lcfirst qq<';
5118 0         0 $left_e++;
5119             }
5120             elsif ($char[$i] eq '\U') {
5121 0         0 $char[$i] = '@{[Elatin1::uc qq<';
5122 0         0 $left_e++;
5123             }
5124             elsif ($char[$i] eq '\L') {
5125 0         0 $char[$i] = '@{[Elatin1::lc qq<';
5126 0         0 $left_e++;
5127             }
5128             elsif ($char[$i] eq '\F') {
5129 24         27 $char[$i] = '@{[Elatin1::fc qq<';
5130 24         41 $left_e++;
5131             }
5132             elsif ($char[$i] eq '\Q') {
5133 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5134 0         0 $left_e++;
5135             }
5136             elsif ($char[$i] eq '\E') {
5137 24 50       31 if ($right_e < $left_e) {
5138 24         21 $char[$i] = '>]}';
5139 24         49 $right_e++;
5140             }
5141             else {
5142 0         0 $char[$i] = '';
5143             }
5144             }
5145             elsif ($char[$i] eq '\Q') {
5146 0         0 while (1) {
5147 0 0       0 if (++$i > $#char) {
5148 0         0 last;
5149             }
5150 0 0       0 if ($char[$i] eq '\E') {
5151 0         0 last;
5152             }
5153             }
5154             }
5155             elsif ($char[$i] eq '\E') {
5156             }
5157              
5158             # $0 --> $0
5159             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5160             }
5161             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5162             }
5163              
5164             # $$ --> $$
5165             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5166             }
5167              
5168             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5169             # $1, $2, $3 --> $1, $2, $3 otherwise
5170             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5171 205         378 $char[$i] = e_capture($1);
5172             }
5173             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5174 0         0 $char[$i] = e_capture($1);
5175             }
5176              
5177             # $$foo[ ... ] --> $ $foo->[ ... ]
5178             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5179 0         0 $char[$i] = e_capture($1.'->'.$2);
5180             }
5181              
5182             # $$foo{ ... } --> $ $foo->{ ... }
5183             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5184 0         0 $char[$i] = e_capture($1.'->'.$2);
5185             }
5186              
5187             # $$foo
5188             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5189 0         0 $char[$i] = e_capture($1);
5190             }
5191              
5192             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
5193             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5194 44         124 $char[$i] = '@{[Elatin1::PREMATCH()]}';
5195             }
5196              
5197             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
5198             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5199 45         129 $char[$i] = '@{[Elatin1::MATCH()]}';
5200             }
5201              
5202             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
5203             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5204 33         91 $char[$i] = '@{[Elatin1::POSTMATCH()]}';
5205             }
5206              
5207             # ${ foo } --> ${ foo }
5208             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5209             }
5210              
5211             # ${ ... }
5212             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5213 0         0 $char[$i] = e_capture($1);
5214             }
5215             }
5216              
5217             # return string
5218 3935 50       7185 if ($left_e > $right_e) {
5219 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5220             }
5221 3935         39497 return join '', $ope, $delimiter, @char, $end_delimiter;
5222             }
5223              
5224             #
5225             # escape qw string (qw//)
5226             #
5227             sub e_qw {
5228 16     16 0 99 my($ope,$delimiter,$end_delimiter,$string) = @_;
5229              
5230 16         31 $slash = 'div';
5231              
5232             # choice again delimiter
5233 16         237 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         597  
5234 16 50       100 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5235 16         136 return join '', $ope, $delimiter, $string, $end_delimiter;
5236             }
5237             elsif (not $octet{')'}) {
5238 0         0 return join '', $ope, '(', $string, ')';
5239             }
5240             elsif (not $octet{'}'}) {
5241 0         0 return join '', $ope, '{', $string, '}';
5242             }
5243             elsif (not $octet{']'}) {
5244 0         0 return join '', $ope, '[', $string, ']';
5245             }
5246             elsif (not $octet{'>'}) {
5247 0         0 return join '', $ope, '<', $string, '>';
5248             }
5249             else {
5250 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5251 0 0       0 if (not $octet{$char}) {
5252 0         0 return join '', $ope, $char, $string, $char;
5253             }
5254             }
5255             }
5256              
5257             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5258 0         0 my @string = CORE::split(/\s+/, $string);
5259 0         0 for my $string (@string) {
5260 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5261 0         0 for my $octet (@octet) {
5262 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5263 0         0 $octet = '\\' . $1;
5264             }
5265             }
5266 0         0 $string = join '', @octet;
5267             }
5268 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5269             }
5270              
5271             #
5272             # escape here document (<<"HEREDOC", <
5273             #
5274             sub e_heredoc {
5275 78     78 0 168 my($string) = @_;
5276              
5277 78         102 $slash = 'm//';
5278              
5279 78         268 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5280              
5281 78         90 my $left_e = 0;
5282 78         77 my $right_e = 0;
5283              
5284             # split regexp
5285 78         7439 my @char = $string =~ /\G((?>
5286             [^\\\$] |
5287             \\x\{ (?>[0-9A-Fa-f]+) \} |
5288             \\o\{ (?>[0-7]+) \} |
5289             \\N\{ (?>[^0-9\}][^\}]*) \} |
5290             \\ $q_char |
5291             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5292             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5293             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5294             \$ (?>\s* [0-9]+) |
5295             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5296             \$ \$ (?![\w\{]) |
5297             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5298             $q_char
5299             ))/oxmsg;
5300              
5301 78         424 for (my $i=0; $i <= $#char; $i++) {
5302              
5303             # "\L\u" --> "\u\L"
5304 2882 50 33     10483 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5305 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5306             }
5307              
5308             # "\U\l" --> "\l\U"
5309             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5310 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5311             }
5312              
5313             # octal escape sequence
5314             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5315 1         2 $char[$i] = Elatin1::octchr($1);
5316             }
5317              
5318             # hexadecimal escape sequence
5319             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5320 1         3 $char[$i] = Elatin1::hexchr($1);
5321             }
5322              
5323             # \N{CHARNAME} --> N{CHARNAME}
5324             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5325 0         0 $char[$i] = $1;
5326             }
5327              
5328 2882 50       29829 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5329             }
5330              
5331             # \u \l \U \L \F \Q \E
5332 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5333 0 0       0 if ($right_e < $left_e) {
5334 0         0 $char[$i] = '\\' . $char[$i];
5335             }
5336             }
5337             elsif ($char[$i] eq '\u') {
5338 0         0 $char[$i] = '@{[Elatin1::ucfirst qq<';
5339 0         0 $left_e++;
5340             }
5341             elsif ($char[$i] eq '\l') {
5342 0         0 $char[$i] = '@{[Elatin1::lcfirst qq<';
5343 0         0 $left_e++;
5344             }
5345             elsif ($char[$i] eq '\U') {
5346 0         0 $char[$i] = '@{[Elatin1::uc qq<';
5347 0         0 $left_e++;
5348             }
5349             elsif ($char[$i] eq '\L') {
5350 0         0 $char[$i] = '@{[Elatin1::lc qq<';
5351 0         0 $left_e++;
5352             }
5353             elsif ($char[$i] eq '\F') {
5354 0         0 $char[$i] = '@{[Elatin1::fc qq<';
5355 0         0 $left_e++;
5356             }
5357             elsif ($char[$i] eq '\Q') {
5358 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5359 0         0 $left_e++;
5360             }
5361             elsif ($char[$i] eq '\E') {
5362 0 0       0 if ($right_e < $left_e) {
5363 0         0 $char[$i] = '>]}';
5364 0         0 $right_e++;
5365             }
5366             else {
5367 0         0 $char[$i] = '';
5368             }
5369             }
5370             elsif ($char[$i] eq '\Q') {
5371 0         0 while (1) {
5372 0 0       0 if (++$i > $#char) {
5373 0         0 last;
5374             }
5375 0 0       0 if ($char[$i] eq '\E') {
5376 0         0 last;
5377             }
5378             }
5379             }
5380             elsif ($char[$i] eq '\E') {
5381             }
5382              
5383             # $0 --> $0
5384             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5385             }
5386             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5387             }
5388              
5389             # $$ --> $$
5390             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5391             }
5392              
5393             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5394             # $1, $2, $3 --> $1, $2, $3 otherwise
5395             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5396 0         0 $char[$i] = e_capture($1);
5397             }
5398             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5399 0         0 $char[$i] = e_capture($1);
5400             }
5401              
5402             # $$foo[ ... ] --> $ $foo->[ ... ]
5403             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5404 0         0 $char[$i] = e_capture($1.'->'.$2);
5405             }
5406              
5407             # $$foo{ ... } --> $ $foo->{ ... }
5408             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5409 0         0 $char[$i] = e_capture($1.'->'.$2);
5410             }
5411              
5412             # $$foo
5413             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5414 0         0 $char[$i] = e_capture($1);
5415             }
5416              
5417             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
5418             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5419 8         43 $char[$i] = '@{[Elatin1::PREMATCH()]}';
5420             }
5421              
5422             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
5423             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5424 8         49 $char[$i] = '@{[Elatin1::MATCH()]}';
5425             }
5426              
5427             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
5428             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5429 6         43 $char[$i] = '@{[Elatin1::POSTMATCH()]}';
5430             }
5431              
5432             # ${ foo } --> ${ foo }
5433             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5434             }
5435              
5436             # ${ ... }
5437             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5438 0         0 $char[$i] = e_capture($1);
5439             }
5440             }
5441              
5442             # return string
5443 78 50       182 if ($left_e > $right_e) {
5444 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5445             }
5446 78         699 return join '', @char;
5447             }
5448              
5449             #
5450             # escape regexp (m//, qr//)
5451             #
5452             sub e_qr {
5453 651     651 0 1900 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5454 651   100     2326 $modifier ||= '';
5455              
5456 651         1004 $modifier =~ tr/p//d;
5457 651 50       1743 if ($modifier =~ /([adlu])/oxms) {
5458 0         0 my $line = 0;
5459 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5460 0 0       0 if ($filename ne __FILE__) {
5461 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5462 0         0 last;
5463             }
5464             }
5465 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5466             }
5467              
5468 651         1250 $slash = 'div';
5469              
5470             # literal null string pattern
5471 651 100       2197 if ($string eq '') {
    100          
5472 8         9 $modifier =~ tr/bB//d;
5473 8         12 $modifier =~ tr/i//d;
5474 8         49 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5475             }
5476              
5477             # /b /B modifier
5478             elsif ($modifier =~ tr/bB//d) {
5479              
5480             # choice again delimiter
5481 2 50       14 if ($delimiter =~ / [\@:] /oxms) {
5482 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5483 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5484 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5485 0         0 $delimiter = '(';
5486 0         0 $end_delimiter = ')';
5487             }
5488             elsif (not $octet{'}'}) {
5489 0         0 $delimiter = '{';
5490 0         0 $end_delimiter = '}';
5491             }
5492             elsif (not $octet{']'}) {
5493 0         0 $delimiter = '[';
5494 0         0 $end_delimiter = ']';
5495             }
5496             elsif (not $octet{'>'}) {
5497 0         0 $delimiter = '<';
5498 0         0 $end_delimiter = '>';
5499             }
5500             else {
5501 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5502 0 0       0 if (not $octet{$char}) {
5503 0         0 $delimiter = $char;
5504 0         0 $end_delimiter = $char;
5505 0         0 last;
5506             }
5507             }
5508             }
5509             }
5510              
5511 2 50 33     12 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5512 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5513             }
5514             else {
5515 2         10 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5516             }
5517             }
5518              
5519 641 100       1541 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5520 641         2583 my $metachar = qr/[\@\\|[\]{^]/oxms;
5521              
5522             # split regexp
5523 641         70944 my @char = $string =~ /\G((?>
5524             [^\\\$\@\[\(] |
5525             \\x (?>[0-9A-Fa-f]{1,2}) |
5526             \\ (?>[0-7]{2,3}) |
5527             \\c [\x40-\x5F] |
5528             \\x\{ (?>[0-9A-Fa-f]+) \} |
5529             \\o\{ (?>[0-7]+) \} |
5530             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5531             \\ $q_char |
5532             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5533             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5534             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5535             [\$\@] $qq_variable |
5536             \$ (?>\s* [0-9]+) |
5537             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5538             \$ \$ (?![\w\{]) |
5539             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5540             \[\^ |
5541             \[\: (?>[a-z]+) :\] |
5542             \[\:\^ (?>[a-z]+) :\] |
5543             \(\? |
5544             $q_char
5545             ))/oxmsg;
5546              
5547             # choice again delimiter
5548 641 50       3273 if ($delimiter =~ / [\@:] /oxms) {
5549 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5550 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5551 0         0 $delimiter = '(';
5552 0         0 $end_delimiter = ')';
5553             }
5554             elsif (not $octet{'}'}) {
5555 0         0 $delimiter = '{';
5556 0         0 $end_delimiter = '}';
5557             }
5558             elsif (not $octet{']'}) {
5559 0         0 $delimiter = '[';
5560 0         0 $end_delimiter = ']';
5561             }
5562             elsif (not $octet{'>'}) {
5563 0         0 $delimiter = '<';
5564 0         0 $end_delimiter = '>';
5565             }
5566             else {
5567 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5568 0 0       0 if (not $octet{$char}) {
5569 0         0 $delimiter = $char;
5570 0         0 $end_delimiter = $char;
5571 0         0 last;
5572             }
5573             }
5574             }
5575             }
5576              
5577 641         849 my $left_e = 0;
5578 641         690 my $right_e = 0;
5579 641         1851 for (my $i=0; $i <= $#char; $i++) {
5580              
5581             # "\L\u" --> "\u\L"
5582 1867 50 66     12271 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5583 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5584             }
5585              
5586             # "\U\l" --> "\l\U"
5587             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5588 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5589             }
5590              
5591             # octal escape sequence
5592             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5593 1         2 $char[$i] = Elatin1::octchr($1);
5594             }
5595              
5596             # hexadecimal escape sequence
5597             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5598 1         3 $char[$i] = Elatin1::hexchr($1);
5599             }
5600              
5601             # \b{...} --> b\{...}
5602             # \B{...} --> B\{...}
5603             # \N{CHARNAME} --> N\{CHARNAME}
5604             # \p{PROPERTY} --> p\{PROPERTY}
5605             # \P{PROPERTY} --> P\{PROPERTY}
5606             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5607 6         17 $char[$i] = $1 . '\\' . $2;
5608             }
5609              
5610             # \p, \P, \X --> p, P, X
5611             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5612 4         12 $char[$i] = $1;
5613             }
5614              
5615 1867 100 100     6527 if (0) {
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5616             }
5617              
5618             # join separated multiple-octet
5619 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5620 6 50 33     101 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)) {
    50 33        
    50 33        
      33        
      66        
      33        
5621 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
5622             }
5623             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)) {
5624 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
5625             }
5626             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)) {
5627 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
5628             }
5629             }
5630              
5631             # open character class [...]
5632             elsif ($char[$i] eq '[') {
5633 328         425 my $left = $i;
5634              
5635             # [] make die "Unmatched [] in regexp ...\n"
5636             # (and so on)
5637              
5638 328 100       940 if ($char[$i+1] eq ']') {
5639 3         5 $i++;
5640             }
5641              
5642 328         364 while (1) {
5643 1379 50       2050 if (++$i > $#char) {
5644 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5645             }
5646 1379 100       2332 if ($char[$i] eq ']') {
5647 328         433 my $right = $i;
5648              
5649             # [...]
5650 328 100       2082 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5651 30         92 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin1::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         142  
5652             }
5653             else {
5654 298         1244 splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
5655             }
5656              
5657 328         521 $i = $left;
5658 328         977 last;
5659             }
5660             }
5661             }
5662              
5663             # open character class [^...]
5664             elsif ($char[$i] eq '[^') {
5665 74         109 my $left = $i;
5666              
5667             # [^] make die "Unmatched [] in regexp ...\n"
5668             # (and so on)
5669              
5670 74 100       217 if ($char[$i+1] eq ']') {
5671 4         7 $i++;
5672             }
5673              
5674 74         87 while (1) {
5675 272 50       422 if (++$i > $#char) {
5676 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5677             }
5678 272 100       535 if ($char[$i] eq ']') {
5679 74         86 my $right = $i;
5680              
5681             # [^...]
5682 74 100       524 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5683 30         111 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin1::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         148  
5684             }
5685             else {
5686 44         230 splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5687             }
5688              
5689 74         122 $i = $left;
5690 74         249 last;
5691             }
5692             }
5693             }
5694              
5695             # rewrite character class or escape character
5696             elsif (my $char = character_class($char[$i],$modifier)) {
5697 139         547 $char[$i] = $char;
5698             }
5699              
5700             # /i modifier
5701             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
5702 20 50       28 if (CORE::length(Elatin1::fc($char[$i])) == 1) {
5703 20         27 $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
5704             }
5705             else {
5706 0         0 $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
5707             }
5708             }
5709              
5710             # \u \l \U \L \F \Q \E
5711             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5712 1 50       6 if ($right_e < $left_e) {
5713 0         0 $char[$i] = '\\' . $char[$i];
5714             }
5715             }
5716             elsif ($char[$i] eq '\u') {
5717 0         0 $char[$i] = '@{[Elatin1::ucfirst qq<';
5718 0         0 $left_e++;
5719             }
5720             elsif ($char[$i] eq '\l') {
5721 0         0 $char[$i] = '@{[Elatin1::lcfirst qq<';
5722 0         0 $left_e++;
5723             }
5724             elsif ($char[$i] eq '\U') {
5725 1         1 $char[$i] = '@{[Elatin1::uc qq<';
5726 1         5 $left_e++;
5727             }
5728             elsif ($char[$i] eq '\L') {
5729 1         2 $char[$i] = '@{[Elatin1::lc qq<';
5730 1         5 $left_e++;
5731             }
5732             elsif ($char[$i] eq '\F') {
5733 18         20 $char[$i] = '@{[Elatin1::fc qq<';
5734 18         78 $left_e++;
5735             }
5736             elsif ($char[$i] eq '\Q') {
5737 1         2 $char[$i] = '@{[CORE::quotemeta qq<';
5738 1         5 $left_e++;
5739             }
5740             elsif ($char[$i] eq '\E') {
5741 21 50       27 if ($right_e < $left_e) {
5742 21         22 $char[$i] = '>]}';
5743 21         76 $right_e++;
5744             }
5745             else {
5746 0         0 $char[$i] = '';
5747             }
5748             }
5749             elsif ($char[$i] eq '\Q') {
5750 0         0 while (1) {
5751 0 0       0 if (++$i > $#char) {
5752 0         0 last;
5753             }
5754 0 0       0 if ($char[$i] eq '\E') {
5755 0         0 last;
5756             }
5757             }
5758             }
5759             elsif ($char[$i] eq '\E') {
5760             }
5761              
5762             # $0 --> $0
5763             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5764 0 0       0 if ($ignorecase) {
5765 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5766             }
5767             }
5768             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5769 0 0       0 if ($ignorecase) {
5770 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5771             }
5772             }
5773              
5774             # $$ --> $$
5775             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5776             }
5777              
5778             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5779             # $1, $2, $3 --> $1, $2, $3 otherwise
5780             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5781 0         0 $char[$i] = e_capture($1);
5782 0 0       0 if ($ignorecase) {
5783 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5784             }
5785             }
5786             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5787 0         0 $char[$i] = e_capture($1);
5788 0 0       0 if ($ignorecase) {
5789 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5790             }
5791             }
5792              
5793             # $$foo[ ... ] --> $ $foo->[ ... ]
5794             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5795 0         0 $char[$i] = e_capture($1.'->'.$2);
5796 0 0       0 if ($ignorecase) {
5797 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5798             }
5799             }
5800              
5801             # $$foo{ ... } --> $ $foo->{ ... }
5802             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5803 0         0 $char[$i] = e_capture($1.'->'.$2);
5804 0 0       0 if ($ignorecase) {
5805 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5806             }
5807             }
5808              
5809             # $$foo
5810             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5811 0         0 $char[$i] = e_capture($1);
5812 0 0       0 if ($ignorecase) {
5813 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5814             }
5815             }
5816              
5817             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
5818             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5819 8 50       20 if ($ignorecase) {
5820 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::PREMATCH())]}';
5821             }
5822             else {
5823 8         45 $char[$i] = '@{[Elatin1::PREMATCH()]}';
5824             }
5825             }
5826              
5827             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
5828             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5829 8 50       22 if ($ignorecase) {
5830 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::MATCH())]}';
5831             }
5832             else {
5833 8         45 $char[$i] = '@{[Elatin1::MATCH()]}';
5834             }
5835             }
5836              
5837             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
5838             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5839 6 50       19 if ($ignorecase) {
5840 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::POSTMATCH())]}';
5841             }
5842             else {
5843 6         36 $char[$i] = '@{[Elatin1::POSTMATCH()]}';
5844             }
5845             }
5846              
5847             # ${ foo }
5848             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5849 0 0       0 if ($ignorecase) {
5850 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5851             }
5852             }
5853              
5854             # ${ ... }
5855             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5856 0         0 $char[$i] = e_capture($1);
5857 0 0       0 if ($ignorecase) {
5858 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5859             }
5860             }
5861              
5862             # $scalar or @array
5863             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5864 21         42 $char[$i] = e_string($char[$i]);
5865 21 100       74 if ($ignorecase) {
5866 11         61 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
5867             }
5868             }
5869              
5870             # quote character before ? + * {
5871             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5872 138 100 33     1214 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5873             }
5874             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5875 0         0 my $char = $char[$i-1];
5876 0 0       0 if ($char[$i] eq '{') {
5877 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5878             }
5879             else {
5880 0         0 die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5881             }
5882             }
5883             else {
5884 127         872 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5885             }
5886             }
5887             }
5888              
5889             # make regexp string
5890 641         949 $modifier =~ tr/i//d;
5891 641 50       1441 if ($left_e > $right_e) {
5892 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5893 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5894             }
5895             else {
5896 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5897             }
5898             }
5899 641 50 33     4109 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5900 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5901             }
5902             else {
5903 641         6385 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5904             }
5905             }
5906              
5907             #
5908             # double quote stuff
5909             #
5910             sub qq_stuff {
5911 180     180 0 241 my($delimiter,$end_delimiter,$stuff) = @_;
5912              
5913             # scalar variable or array variable
5914 180 100       465 if ($stuff =~ /\A [\$\@] /oxms) {
5915 100         442 return $stuff;
5916             }
5917              
5918             # quote by delimiter
5919 80         226 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         319  
5920 80         231 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5921 80 50       175 next if $char eq $delimiter;
5922 80 50       141 next if $char eq $end_delimiter;
5923 80 50       175 if (not $octet{$char}) {
5924 80         489 return join '', 'qq', $char, $stuff, $char;
5925             }
5926             }
5927 0         0 return join '', 'qq', '<', $stuff, '>';
5928             }
5929              
5930             #
5931             # escape regexp (m'', qr'', and m''b, qr''b)
5932             #
5933             sub e_qr_q {
5934 10     10 0 32 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5935 10   50     43 $modifier ||= '';
5936              
5937 10         14 $modifier =~ tr/p//d;
5938 10 50       27 if ($modifier =~ /([adlu])/oxms) {
5939 0         0 my $line = 0;
5940 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5941 0 0       0 if ($filename ne __FILE__) {
5942 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5943 0         0 last;
5944             }
5945             }
5946 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5947             }
5948              
5949 10         15 $slash = 'div';
5950              
5951             # literal null string pattern
5952 10 100       29 if ($string eq '') {
    50          
5953 8         6 $modifier =~ tr/bB//d;
5954 8         12 $modifier =~ tr/i//d;
5955 8         44 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5956             }
5957              
5958             # with /b /B modifier
5959             elsif ($modifier =~ tr/bB//d) {
5960 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5961             }
5962              
5963             # without /b /B modifier
5964             else {
5965 2         10 return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5966             }
5967             }
5968              
5969             #
5970             # escape regexp (m'', qr'')
5971             #
5972             sub e_qr_qt {
5973 2     2 0 5 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5974              
5975 2 50       8 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5976              
5977             # split regexp
5978 2         104 my @char = $string =~ /\G((?>
5979             [^\\\[\$\@\/] |
5980             [\x00-\xFF] |
5981             \[\^ |
5982             \[\: (?>[a-z]+) \:\] |
5983             \[\:\^ (?>[a-z]+) \:\] |
5984             [\$\@\/] |
5985             \\ (?:$q_char) |
5986             (?:$q_char)
5987             ))/oxmsg;
5988              
5989             # unescape character
5990 2         13 for (my $i=0; $i <= $#char; $i++) {
5991 2 50 33     23 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
5992             }
5993              
5994             # open character class [...]
5995 0         0 elsif ($char[$i] eq '[') {
5996 0         0 my $left = $i;
5997 0 0       0 if ($char[$i+1] eq ']') {
5998 0         0 $i++;
5999             }
6000 0         0 while (1) {
6001 0 0       0 if (++$i > $#char) {
6002 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6003             }
6004 0 0       0 if ($char[$i] eq ']') {
6005 0         0 my $right = $i;
6006              
6007             # [...]
6008 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
6009              
6010 0         0 $i = $left;
6011 0         0 last;
6012             }
6013             }
6014             }
6015              
6016             # open character class [^...]
6017             elsif ($char[$i] eq '[^') {
6018 0         0 my $left = $i;
6019 0 0       0 if ($char[$i+1] eq ']') {
6020 0         0 $i++;
6021             }
6022 0         0 while (1) {
6023 0 0       0 if (++$i > $#char) {
6024 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6025             }
6026 0 0       0 if ($char[$i] eq ']') {
6027 0         0 my $right = $i;
6028              
6029             # [^...]
6030 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6031              
6032 0         0 $i = $left;
6033 0         0 last;
6034             }
6035             }
6036             }
6037              
6038             # escape $ @ / and \
6039             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6040 0         0 $char[$i] = '\\' . $char[$i];
6041             }
6042              
6043             # rewrite character class or escape character
6044             elsif (my $char = character_class($char[$i],$modifier)) {
6045 0         0 $char[$i] = $char;
6046             }
6047              
6048             # /i modifier
6049             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
6050 0 0       0 if (CORE::length(Elatin1::fc($char[$i])) == 1) {
6051 0         0 $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
6052             }
6053             else {
6054 0         0 $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
6055             }
6056             }
6057              
6058             # quote character before ? + * {
6059             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6060 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6061             }
6062             else {
6063 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6064             }
6065             }
6066             }
6067              
6068 2         5 $delimiter = '/';
6069 2         4 $end_delimiter = '/';
6070              
6071 2         3 $modifier =~ tr/i//d;
6072 2         15 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6073             }
6074              
6075             #
6076             # escape regexp (m''b, qr''b)
6077             #
6078             sub e_qr_qb {
6079 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6080              
6081             # split regexp
6082 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6083              
6084             # unescape character
6085 0         0 for (my $i=0; $i <= $#char; $i++) {
6086 0 0       0 if (0) {
    0          
6087             }
6088              
6089             # remain \\
6090 0         0 elsif ($char[$i] eq '\\\\') {
6091             }
6092              
6093             # escape $ @ / and \
6094             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6095 0         0 $char[$i] = '\\' . $char[$i];
6096             }
6097             }
6098              
6099 0         0 $delimiter = '/';
6100 0         0 $end_delimiter = '/';
6101 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6102             }
6103              
6104             #
6105             # escape regexp (s/here//)
6106             #
6107             sub e_s1 {
6108 76     76 0 193 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6109 76   100     298 $modifier ||= '';
6110              
6111 76         117 $modifier =~ tr/p//d;
6112 76 50       249 if ($modifier =~ /([adlu])/oxms) {
6113 0         0 my $line = 0;
6114 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6115 0 0       0 if ($filename ne __FILE__) {
6116 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6117 0         0 last;
6118             }
6119             }
6120 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6121             }
6122              
6123 76         137 $slash = 'div';
6124              
6125             # literal null string pattern
6126 76 100       320 if ($string eq '') {
    50          
6127 8         9 $modifier =~ tr/bB//d;
6128 8         11 $modifier =~ tr/i//d;
6129 8         65 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6130             }
6131              
6132             # /b /B modifier
6133             elsif ($modifier =~ tr/bB//d) {
6134              
6135             # choice again delimiter
6136 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
6137 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6138 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6139 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6140 0         0 $delimiter = '(';
6141 0         0 $end_delimiter = ')';
6142             }
6143             elsif (not $octet{'}'}) {
6144 0         0 $delimiter = '{';
6145 0         0 $end_delimiter = '}';
6146             }
6147             elsif (not $octet{']'}) {
6148 0         0 $delimiter = '[';
6149 0         0 $end_delimiter = ']';
6150             }
6151             elsif (not $octet{'>'}) {
6152 0         0 $delimiter = '<';
6153 0         0 $end_delimiter = '>';
6154             }
6155             else {
6156 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6157 0 0       0 if (not $octet{$char}) {
6158 0         0 $delimiter = $char;
6159 0         0 $end_delimiter = $char;
6160 0         0 last;
6161             }
6162             }
6163             }
6164             }
6165              
6166 0         0 my $prematch = '';
6167 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6168             }
6169              
6170 68 100       200 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6171 68         317 my $metachar = qr/[\@\\|[\]{^]/oxms;
6172              
6173             # split regexp
6174 68         19712 my @char = $string =~ /\G((?>
6175             [^\\\$\@\[\(] |
6176             \\ (?>[1-9][0-9]*) |
6177             \\g (?>\s*) (?>[1-9][0-9]*) |
6178             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6179             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6180             \\x (?>[0-9A-Fa-f]{1,2}) |
6181             \\ (?>[0-7]{2,3}) |
6182             \\c [\x40-\x5F] |
6183             \\x\{ (?>[0-9A-Fa-f]+) \} |
6184             \\o\{ (?>[0-7]+) \} |
6185             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6186             \\ $q_char |
6187             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6188             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6189             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6190             [\$\@] $qq_variable |
6191             \$ (?>\s* [0-9]+) |
6192             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6193             \$ \$ (?![\w\{]) |
6194             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6195             \[\^ |
6196             \[\: (?>[a-z]+) :\] |
6197             \[\:\^ (?>[a-z]+) :\] |
6198             \(\? |
6199             $q_char
6200             ))/oxmsg;
6201              
6202             # choice again delimiter
6203 68 50       613 if ($delimiter =~ / [\@:] /oxms) {
6204 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6205 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6206 0         0 $delimiter = '(';
6207 0         0 $end_delimiter = ')';
6208             }
6209             elsif (not $octet{'}'}) {
6210 0         0 $delimiter = '{';
6211 0         0 $end_delimiter = '}';
6212             }
6213             elsif (not $octet{']'}) {
6214 0         0 $delimiter = '[';
6215 0         0 $end_delimiter = ']';
6216             }
6217             elsif (not $octet{'>'}) {
6218 0         0 $delimiter = '<';
6219 0         0 $end_delimiter = '>';
6220             }
6221             else {
6222 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6223 0 0       0 if (not $octet{$char}) {
6224 0         0 $delimiter = $char;
6225 0         0 $end_delimiter = $char;
6226 0         0 last;
6227             }
6228             }
6229             }
6230             }
6231              
6232             # count '('
6233 68         140 my $parens = grep { $_ eq '(' } @char;
  253         469  
6234              
6235 68         102 my $left_e = 0;
6236 68         93 my $right_e = 0;
6237 68         274 for (my $i=0; $i <= $#char; $i++) {
6238              
6239             # "\L\u" --> "\u\L"
6240 195 50 33     1674 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6241 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6242             }
6243              
6244             # "\U\l" --> "\l\U"
6245             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6246 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6247             }
6248              
6249             # octal escape sequence
6250             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6251 1         3 $char[$i] = Elatin1::octchr($1);
6252             }
6253              
6254             # hexadecimal escape sequence
6255             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6256 1         3 $char[$i] = Elatin1::hexchr($1);
6257             }
6258              
6259             # \b{...} --> b\{...}
6260             # \B{...} --> B\{...}
6261             # \N{CHARNAME} --> N\{CHARNAME}
6262             # \p{PROPERTY} --> p\{PROPERTY}
6263             # \P{PROPERTY} --> P\{PROPERTY}
6264             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6265 0         0 $char[$i] = $1 . '\\' . $2;
6266             }
6267              
6268             # \p, \P, \X --> p, P, X
6269             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6270 0         0 $char[$i] = $1;
6271             }
6272              
6273 195 50 66     885 if (0) {
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6274             }
6275              
6276             # join separated multiple-octet
6277 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6278 0 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        
6279 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
6280             }
6281             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)) {
6282 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
6283             }
6284             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)) {
6285 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
6286             }
6287             }
6288              
6289             # open character class [...]
6290             elsif ($char[$i] eq '[') {
6291 13         22 my $left = $i;
6292 13 50       58 if ($char[$i+1] eq ']') {
6293 0         0 $i++;
6294             }
6295 13         16 while (1) {
6296 58 50       94 if (++$i > $#char) {
6297 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6298             }
6299 58 100       108 if ($char[$i] eq ']') {
6300 13         16 my $right = $i;
6301              
6302             # [...]
6303 13 50       104 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6304 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin1::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6305             }
6306             else {
6307 13         90 splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
6308             }
6309              
6310 13         25 $i = $left;
6311 13         47 last;
6312             }
6313             }
6314             }
6315              
6316             # open character class [^...]
6317             elsif ($char[$i] eq '[^') {
6318 0         0 my $left = $i;
6319 0 0       0 if ($char[$i+1] eq ']') {
6320 0         0 $i++;
6321             }
6322 0         0 while (1) {
6323 0 0       0 if (++$i > $#char) {
6324 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6325             }
6326 0 0       0 if ($char[$i] eq ']') {
6327 0         0 my $right = $i;
6328              
6329             # [^...]
6330 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6331 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin1::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6332             }
6333             else {
6334 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6335             }
6336              
6337 0         0 $i = $left;
6338 0         0 last;
6339             }
6340             }
6341             }
6342              
6343             # rewrite character class or escape character
6344             elsif (my $char = character_class($char[$i],$modifier)) {
6345 7         26 $char[$i] = $char;
6346             }
6347              
6348             # /i modifier
6349             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
6350 3 50       6 if (CORE::length(Elatin1::fc($char[$i])) == 1) {
6351 3         7 $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
6352             }
6353             else {
6354 0         0 $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
6355             }
6356             }
6357              
6358             # \u \l \U \L \F \Q \E
6359             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6360 0 0       0 if ($right_e < $left_e) {
6361 0         0 $char[$i] = '\\' . $char[$i];
6362             }
6363             }
6364             elsif ($char[$i] eq '\u') {
6365 0         0 $char[$i] = '@{[Elatin1::ucfirst qq<';
6366 0         0 $left_e++;
6367             }
6368             elsif ($char[$i] eq '\l') {
6369 0         0 $char[$i] = '@{[Elatin1::lcfirst qq<';
6370 0         0 $left_e++;
6371             }
6372             elsif ($char[$i] eq '\U') {
6373 0         0 $char[$i] = '@{[Elatin1::uc qq<';
6374 0         0 $left_e++;
6375             }
6376             elsif ($char[$i] eq '\L') {
6377 0         0 $char[$i] = '@{[Elatin1::lc qq<';
6378 0         0 $left_e++;
6379             }
6380             elsif ($char[$i] eq '\F') {
6381 0         0 $char[$i] = '@{[Elatin1::fc qq<';
6382 0         0 $left_e++;
6383             }
6384             elsif ($char[$i] eq '\Q') {
6385 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6386 0         0 $left_e++;
6387             }
6388             elsif ($char[$i] eq '\E') {
6389 0 0       0 if ($right_e < $left_e) {
6390 0         0 $char[$i] = '>]}';
6391 0         0 $right_e++;
6392             }
6393             else {
6394 0         0 $char[$i] = '';
6395             }
6396             }
6397             elsif ($char[$i] eq '\Q') {
6398 0         0 while (1) {
6399 0 0       0 if (++$i > $#char) {
6400 0         0 last;
6401             }
6402 0 0       0 if ($char[$i] eq '\E') {
6403 0         0 last;
6404             }
6405             }
6406             }
6407             elsif ($char[$i] eq '\E') {
6408             }
6409              
6410             # \0 --> \0
6411             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6412             }
6413              
6414             # \g{N}, \g{-N}
6415              
6416             # P.108 Using Simple Patterns
6417             # in Chapter 7: In the World of Regular Expressions
6418             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6419              
6420             # P.221 Capturing
6421             # in Chapter 5: Pattern Matching
6422             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6423              
6424             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6425             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6426             }
6427              
6428             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6429             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6430             }
6431              
6432             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6433             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6434             }
6435              
6436             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6437             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6438             }
6439              
6440             # $0 --> $0
6441             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6442 0 0       0 if ($ignorecase) {
6443 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6444             }
6445             }
6446             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6447 0 0       0 if ($ignorecase) {
6448 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6449             }
6450             }
6451              
6452             # $$ --> $$
6453             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6454             }
6455              
6456             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6457             # $1, $2, $3 --> $1, $2, $3 otherwise
6458             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6459 0         0 $char[$i] = e_capture($1);
6460 0 0       0 if ($ignorecase) {
6461 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6462             }
6463             }
6464             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6465 0         0 $char[$i] = e_capture($1);
6466 0 0       0 if ($ignorecase) {
6467 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6468             }
6469             }
6470              
6471             # $$foo[ ... ] --> $ $foo->[ ... ]
6472             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6473 0         0 $char[$i] = e_capture($1.'->'.$2);
6474 0 0       0 if ($ignorecase) {
6475 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6476             }
6477             }
6478              
6479             # $$foo{ ... } --> $ $foo->{ ... }
6480             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6481 0         0 $char[$i] = e_capture($1.'->'.$2);
6482 0 0       0 if ($ignorecase) {
6483 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6484             }
6485             }
6486              
6487             # $$foo
6488             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6489 0         0 $char[$i] = e_capture($1);
6490 0 0       0 if ($ignorecase) {
6491 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6492             }
6493             }
6494              
6495             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
6496             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6497 4 50       11 if ($ignorecase) {
6498 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::PREMATCH())]}';
6499             }
6500             else {
6501 4         27 $char[$i] = '@{[Elatin1::PREMATCH()]}';
6502             }
6503             }
6504              
6505             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
6506             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6507 4 50       11 if ($ignorecase) {
6508 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::MATCH())]}';
6509             }
6510             else {
6511 4         23 $char[$i] = '@{[Elatin1::MATCH()]}';
6512             }
6513             }
6514              
6515             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
6516             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6517 3 50       10 if ($ignorecase) {
6518 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::POSTMATCH())]}';
6519             }
6520             else {
6521 3         17 $char[$i] = '@{[Elatin1::POSTMATCH()]}';
6522             }
6523             }
6524              
6525             # ${ foo }
6526             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6527 0 0       0 if ($ignorecase) {
6528 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6529             }
6530             }
6531              
6532             # ${ ... }
6533             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6534 0         0 $char[$i] = e_capture($1);
6535 0 0       0 if ($ignorecase) {
6536 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6537             }
6538             }
6539              
6540             # $scalar or @array
6541             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6542 4         10 $char[$i] = e_string($char[$i]);
6543 4 50       45 if ($ignorecase) {
6544 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6545             }
6546             }
6547              
6548             # quote character before ? + * {
6549             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6550 13 50       70 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6551             }
6552             else {
6553 13         140 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6554             }
6555             }
6556             }
6557              
6558             # make regexp string
6559 68         154 my $prematch = '';
6560 68         119 $modifier =~ tr/i//d;
6561 68 50       267 if ($left_e > $right_e) {
6562 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6563             }
6564 68         965 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6565             }
6566              
6567             #
6568             # escape regexp (s'here'' or s'here''b)
6569             #
6570             sub e_s1_q {
6571 21     21 0 52 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6572 21   100     89 $modifier ||= '';
6573              
6574 21         25 $modifier =~ tr/p//d;
6575 21 50       68 if ($modifier =~ /([adlu])/oxms) {
6576 0         0 my $line = 0;
6577 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6578 0 0       0 if ($filename ne __FILE__) {
6579 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6580 0         0 last;
6581             }
6582             }
6583 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6584             }
6585              
6586 21         34 $slash = 'div';
6587              
6588             # literal null string pattern
6589 21 100       68 if ($string eq '') {
    50          
6590 8         7 $modifier =~ tr/bB//d;
6591 8         12 $modifier =~ tr/i//d;
6592 8         86 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6593             }
6594              
6595             # with /b /B modifier
6596             elsif ($modifier =~ tr/bB//d) {
6597 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6598             }
6599              
6600             # without /b /B modifier
6601             else {
6602 13         44 return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6603             }
6604             }
6605              
6606             #
6607             # escape regexp (s'here'')
6608             #
6609             sub e_s1_qt {
6610 13     13 0 33 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6611              
6612 13 50       39 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6613              
6614             # split regexp
6615 13         370 my @char = $string =~ /\G((?>
6616             [^\\\[\$\@\/] |
6617             [\x00-\xFF] |
6618             \[\^ |
6619             \[\: (?>[a-z]+) \:\] |
6620             \[\:\^ (?>[a-z]+) \:\] |
6621             [\$\@\/] |
6622             \\ (?:$q_char) |
6623             (?:$q_char)
6624             ))/oxmsg;
6625              
6626             # unescape character
6627 13         61 for (my $i=0; $i <= $#char; $i++) {
6628 25 50 33     189 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6629             }
6630              
6631             # open character class [...]
6632 0         0 elsif ($char[$i] eq '[') {
6633 0         0 my $left = $i;
6634 0 0       0 if ($char[$i+1] eq ']') {
6635 0         0 $i++;
6636             }
6637 0         0 while (1) {
6638 0 0       0 if (++$i > $#char) {
6639 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6640             }
6641 0 0       0 if ($char[$i] eq ']') {
6642 0         0 my $right = $i;
6643              
6644             # [...]
6645 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
6646              
6647 0         0 $i = $left;
6648 0         0 last;
6649             }
6650             }
6651             }
6652              
6653             # open character class [^...]
6654             elsif ($char[$i] eq '[^') {
6655 0         0 my $left = $i;
6656 0 0       0 if ($char[$i+1] eq ']') {
6657 0         0 $i++;
6658             }
6659 0         0 while (1) {
6660 0 0       0 if (++$i > $#char) {
6661 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6662             }
6663 0 0       0 if ($char[$i] eq ']') {
6664 0         0 my $right = $i;
6665              
6666             # [^...]
6667 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6668              
6669 0         0 $i = $left;
6670 0         0 last;
6671             }
6672             }
6673             }
6674              
6675             # escape $ @ / and \
6676             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6677 0         0 $char[$i] = '\\' . $char[$i];
6678             }
6679              
6680             # rewrite character class or escape character
6681             elsif (my $char = character_class($char[$i],$modifier)) {
6682 6         19 $char[$i] = $char;
6683             }
6684              
6685             # /i modifier
6686             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
6687 0 0       0 if (CORE::length(Elatin1::fc($char[$i])) == 1) {
6688 0         0 $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
6689             }
6690             else {
6691 0         0 $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
6692             }
6693             }
6694              
6695             # quote character before ? + * {
6696             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6697 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6698             }
6699             else {
6700 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6701             }
6702             }
6703             }
6704              
6705 13         28 $modifier =~ tr/i//d;
6706 13         24 $delimiter = '/';
6707 13         17 $end_delimiter = '/';
6708 13         18 my $prematch = '';
6709 13         184 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6710             }
6711              
6712             #
6713             # escape regexp (s'here''b)
6714             #
6715             sub e_s1_qb {
6716 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6717              
6718             # split regexp
6719 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6720              
6721             # unescape character
6722 0         0 for (my $i=0; $i <= $#char; $i++) {
6723 0 0       0 if (0) {
    0          
6724             }
6725              
6726             # remain \\
6727 0         0 elsif ($char[$i] eq '\\\\') {
6728             }
6729              
6730             # escape $ @ / and \
6731             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6732 0         0 $char[$i] = '\\' . $char[$i];
6733             }
6734             }
6735              
6736 0         0 $delimiter = '/';
6737 0         0 $end_delimiter = '/';
6738 0         0 my $prematch = '';
6739 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6740             }
6741              
6742             #
6743             # escape regexp (s''here')
6744             #
6745             sub e_s2_q {
6746 16     16 0 41 my($ope,$delimiter,$end_delimiter,$string) = @_;
6747              
6748 16         22 $slash = 'div';
6749              
6750 16         161 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6751 16         62 for (my $i=0; $i <= $#char; $i++) {
6752 9 100       48 if (0) {
    100          
6753             }
6754              
6755             # not escape \\
6756 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6757             }
6758              
6759             # escape $ @ / and \
6760             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6761 5         20 $char[$i] = '\\' . $char[$i];
6762             }
6763             }
6764              
6765 16         67 return join '', $ope, $delimiter, @char, $end_delimiter;
6766             }
6767              
6768             #
6769             # escape regexp (s/here/and here/modifier)
6770             #
6771             sub e_sub {
6772 97     97 0 557 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6773 97   100     439 $modifier ||= '';
6774              
6775 97         197 $modifier =~ tr/p//d;
6776 97 50       323 if ($modifier =~ /([adlu])/oxms) {
6777 0         0 my $line = 0;
6778 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6779 0 0       0 if ($filename ne __FILE__) {
6780 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6781 0         0 last;
6782             }
6783             }
6784 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6785             }
6786              
6787 97 100       292 if ($variable eq '') {
6788 36         43 $variable = '$_';
6789 36         55 $bind_operator = ' =~ ';
6790             }
6791              
6792 97         186 $slash = 'div';
6793              
6794             # P.128 Start of match (or end of previous match): \G
6795             # P.130 Advanced Use of \G with Perl
6796             # in Chapter 3: Overview of Regular Expression Features and Flavors
6797             # P.312 Iterative Matching: Scalar Context, with /g
6798             # in Chapter 7: Perl
6799             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6800              
6801             # P.181 Where You Left Off: The \G Assertion
6802             # in Chapter 5: Pattern Matching
6803             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6804              
6805             # P.220 Where You Left Off: The \G Assertion
6806             # in Chapter 5: Pattern Matching
6807             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6808              
6809 97         162 my $e_modifier = $modifier =~ tr/e//d;
6810 97         148 my $r_modifier = $modifier =~ tr/r//d;
6811              
6812 97         249 my $my = '';
6813 97 50       284 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6814 0         0 $my = $variable;
6815 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6816 0         0 $variable =~ s/ = .+ \z//oxms;
6817             }
6818              
6819 97         250 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6820 97         184 $variable_basename =~ s/ \s+ \z//oxms;
6821              
6822             # quote replacement string
6823 97         137 my $e_replacement = '';
6824 97 100       498 if ($e_modifier >= 1) {
6825 17         54 $e_replacement = e_qq('', '', '', $replacement);
6826 17         34 $e_modifier--;
6827             }
6828             else {
6829 80 100       220 if ($delimiter2 eq "'") {
6830 16         49 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6831             }
6832             else {
6833 64         170 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6834             }
6835             }
6836              
6837 97         201 my $sub = '';
6838              
6839             # with /r
6840 97 100       252 if ($r_modifier) {
6841 8 100       26 if (0) {
6842             }
6843              
6844             # s///gr without multibyte anchoring
6845 0         0 elsif ($modifier =~ /g/oxms) {
6846 4 50       25 $sub = sprintf(
6847             # 1 2 3 4 5
6848             q,
6849              
6850             $variable, # 1
6851             ($delimiter1 eq "'") ? # 2
6852             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6853             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6854             $s_matched, # 3
6855             $e_replacement, # 4
6856             '$Latin1::re_r=CORE::eval $Latin1::re_r; ' x $e_modifier, # 5
6857             );
6858             }
6859              
6860             # s///r
6861             else {
6862              
6863 4         7 my $prematch = q{$`};
6864              
6865 4 50       22 $sub = sprintf(
6866             # 1 2 3 4 5 6 7
6867             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin1::re_r=%s; %s"%s$Latin1::re_r$'" } : %s>,
6868              
6869             $variable, # 1
6870             ($delimiter1 eq "'") ? # 2
6871             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6872             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6873             $s_matched, # 3
6874             $e_replacement, # 4
6875             '$Latin1::re_r=CORE::eval $Latin1::re_r; ' x $e_modifier, # 5
6876             $prematch, # 6
6877             $variable, # 7
6878             );
6879             }
6880              
6881             # $var !~ s///r doesn't make sense
6882 8 50       30 if ($bind_operator =~ / !~ /oxms) {
6883 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6884             }
6885             }
6886              
6887             # without /r
6888             else {
6889 89 100       255 if (0) {
6890             }
6891              
6892             # s///g without multibyte anchoring
6893 0         0 elsif ($modifier =~ /g/oxms) {
6894 22 100       121 $sub = sprintf(
    100          
6895             # 1 2 3 4 5 6 7 8
6896             q,
6897              
6898             $variable, # 1
6899             ($delimiter1 eq "'") ? # 2
6900             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6901             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6902             $s_matched, # 3
6903             $e_replacement, # 4
6904             '$Latin1::re_r=CORE::eval $Latin1::re_r; ' x $e_modifier, # 5
6905             $variable, # 6
6906             $variable, # 7
6907             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6908             );
6909             }
6910              
6911             # s///
6912             else {
6913              
6914 67         113 my $prematch = q{$`};
6915              
6916 67 100       509 $sub = sprintf(
    100          
6917              
6918             ($bind_operator =~ / =~ /oxms) ?
6919              
6920             # 1 2 3 4 5 6 7 8
6921             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin1::re_r=%s; %s%s="%s$Latin1::re_r$'"; 1 } : undef> :
6922              
6923             # 1 2 3 4 5 6 7 8
6924             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin1::re_r=%s; %s%s="%s$Latin1::re_r$'"; undef }>,
6925              
6926             $variable, # 1
6927             $bind_operator, # 2
6928             ($delimiter1 eq "'") ? # 3
6929             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6930             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6931             $s_matched, # 4
6932             $e_replacement, # 5
6933             '$Latin1::re_r=CORE::eval $Latin1::re_r; ' x $e_modifier, # 6
6934             $variable, # 7
6935             $prematch, # 8
6936             );
6937             }
6938             }
6939              
6940             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6941 97 50       317 if ($my ne '') {
6942 0         0 $sub = "($my, $sub)[1]";
6943             }
6944              
6945             # clear s/// variable
6946 97         150 $sub_variable = '';
6947 97         203 $bind_operator = '';
6948              
6949 97         810 return $sub;
6950             }
6951              
6952             #
6953             # escape regexp of split qr//
6954             #
6955             sub e_split {
6956 74     74 0 239 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6957 74   100     335 $modifier ||= '';
6958              
6959 74         103 $modifier =~ tr/p//d;
6960 74 50       317 if ($modifier =~ /([adlu])/oxms) {
6961 0         0 my $line = 0;
6962 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6963 0 0       0 if ($filename ne __FILE__) {
6964 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6965 0         0 last;
6966             }
6967             }
6968 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6969             }
6970              
6971 74         133 $slash = 'div';
6972              
6973             # /b /B modifier
6974 74 50       160 if ($modifier =~ tr/bB//d) {
6975 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6976             }
6977              
6978 74 50       257 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6979 74         324 my $metachar = qr/[\@\\|[\]{^]/oxms;
6980              
6981             # split regexp
6982 74         9789 my @char = $string =~ /\G((?>
6983             [^\\\$\@\[\(] |
6984             \\x (?>[0-9A-Fa-f]{1,2}) |
6985             \\ (?>[0-7]{2,3}) |
6986             \\c [\x40-\x5F] |
6987             \\x\{ (?>[0-9A-Fa-f]+) \} |
6988             \\o\{ (?>[0-7]+) \} |
6989             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6990             \\ $q_char |
6991             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6992             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6993             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6994             [\$\@] $qq_variable |
6995             \$ (?>\s* [0-9]+) |
6996             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6997             \$ \$ (?![\w\{]) |
6998             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6999             \[\^ |
7000             \[\: (?>[a-z]+) :\] |
7001             \[\:\^ (?>[a-z]+) :\] |
7002             \(\? |
7003             $q_char
7004             ))/oxmsg;
7005              
7006 74         264 my $left_e = 0;
7007 74         89 my $right_e = 0;
7008 74         280 for (my $i=0; $i <= $#char; $i++) {
7009              
7010             # "\L\u" --> "\u\L"
7011 249 50 33     1470 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7012 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7013             }
7014              
7015             # "\U\l" --> "\l\U"
7016             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7017 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7018             }
7019              
7020             # octal escape sequence
7021             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7022 1         3 $char[$i] = Elatin1::octchr($1);
7023             }
7024              
7025             # hexadecimal escape sequence
7026             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7027 1         2 $char[$i] = Elatin1::hexchr($1);
7028             }
7029              
7030             # \b{...} --> b\{...}
7031             # \B{...} --> B\{...}
7032             # \N{CHARNAME} --> N\{CHARNAME}
7033             # \p{PROPERTY} --> p\{PROPERTY}
7034             # \P{PROPERTY} --> P\{PROPERTY}
7035             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7036 0         0 $char[$i] = $1 . '\\' . $2;
7037             }
7038              
7039             # \p, \P, \X --> p, P, X
7040             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7041 0         0 $char[$i] = $1;
7042             }
7043              
7044 249 50 100     806 if (0) {
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7045             }
7046              
7047             # join separated multiple-octet
7048 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7049 0 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        
7050 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
7051             }
7052             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)) {
7053 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
7054             }
7055             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)) {
7056 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
7057             }
7058             }
7059              
7060             # open character class [...]
7061             elsif ($char[$i] eq '[') {
7062 3         5 my $left = $i;
7063 3 50       10 if ($char[$i+1] eq ']') {
7064 0         0 $i++;
7065             }
7066 3         4 while (1) {
7067 7 50       22 if (++$i > $#char) {
7068 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7069             }
7070 7 100       12 if ($char[$i] eq ']') {
7071 3         4 my $right = $i;
7072              
7073             # [...]
7074 3 50       17 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7075 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin1::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7076             }
7077             else {
7078 3         12 splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
7079             }
7080              
7081 3         6 $i = $left;
7082 3         6 last;
7083             }
7084             }
7085             }
7086              
7087             # open character class [^...]
7088             elsif ($char[$i] eq '[^') {
7089 0         0 my $left = $i;
7090 0 0       0 if ($char[$i+1] eq ']') {
7091 0         0 $i++;
7092             }
7093 0         0 while (1) {
7094 0 0       0 if (++$i > $#char) {
7095 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7096             }
7097 0 0       0 if ($char[$i] eq ']') {
7098 0         0 my $right = $i;
7099              
7100             # [^...]
7101 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7102 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin1::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7103             }
7104             else {
7105 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7106             }
7107              
7108 0         0 $i = $left;
7109 0         0 last;
7110             }
7111             }
7112             }
7113              
7114             # rewrite character class or escape character
7115             elsif (my $char = character_class($char[$i],$modifier)) {
7116 1         2 $char[$i] = $char;
7117             }
7118              
7119             # P.794 29.2.161. split
7120             # in Chapter 29: Functions
7121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7122              
7123             # P.951 split
7124             # in Chapter 27: Functions
7125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7126              
7127             # said "The //m modifier is assumed when you split on the pattern /^/",
7128             # but perl5.008 is not so. Therefore, this software adds //m.
7129             # (and so on)
7130              
7131             # split(m/^/) --> split(m/^/m)
7132             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7133 7         38 $modifier .= 'm';
7134             }
7135              
7136             # /i modifier
7137             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
7138 0 0       0 if (CORE::length(Elatin1::fc($char[$i])) == 1) {
7139 0         0 $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
7140             }
7141             else {
7142 0         0 $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
7143             }
7144             }
7145              
7146             # \u \l \U \L \F \Q \E
7147             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7148 0 0       0 if ($right_e < $left_e) {
7149 0         0 $char[$i] = '\\' . $char[$i];
7150             }
7151             }
7152             elsif ($char[$i] eq '\u') {
7153 0         0 $char[$i] = '@{[Elatin1::ucfirst qq<';
7154 0         0 $left_e++;
7155             }
7156             elsif ($char[$i] eq '\l') {
7157 0         0 $char[$i] = '@{[Elatin1::lcfirst qq<';
7158 0         0 $left_e++;
7159             }
7160             elsif ($char[$i] eq '\U') {
7161 0         0 $char[$i] = '@{[Elatin1::uc qq<';
7162 0         0 $left_e++;
7163             }
7164             elsif ($char[$i] eq '\L') {
7165 0         0 $char[$i] = '@{[Elatin1::lc qq<';
7166 0         0 $left_e++;
7167             }
7168             elsif ($char[$i] eq '\F') {
7169 0         0 $char[$i] = '@{[Elatin1::fc qq<';
7170 0         0 $left_e++;
7171             }
7172             elsif ($char[$i] eq '\Q') {
7173 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7174 0         0 $left_e++;
7175             }
7176             elsif ($char[$i] eq '\E') {
7177 0 0       0 if ($right_e < $left_e) {
7178 0         0 $char[$i] = '>]}';
7179 0         0 $right_e++;
7180             }
7181             else {
7182 0         0 $char[$i] = '';
7183             }
7184             }
7185             elsif ($char[$i] eq '\Q') {
7186 0         0 while (1) {
7187 0 0       0 if (++$i > $#char) {
7188 0         0 last;
7189             }
7190 0 0       0 if ($char[$i] eq '\E') {
7191 0         0 last;
7192             }
7193             }
7194             }
7195             elsif ($char[$i] eq '\E') {
7196             }
7197              
7198             # $0 --> $0
7199             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7200 0 0       0 if ($ignorecase) {
7201 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7202             }
7203             }
7204             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7205 0 0       0 if ($ignorecase) {
7206 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7207             }
7208             }
7209              
7210             # $$ --> $$
7211             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7212             }
7213              
7214             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7215             # $1, $2, $3 --> $1, $2, $3 otherwise
7216             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7217 0         0 $char[$i] = e_capture($1);
7218 0 0       0 if ($ignorecase) {
7219 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7220             }
7221             }
7222             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7223 0         0 $char[$i] = e_capture($1);
7224 0 0       0 if ($ignorecase) {
7225 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7226             }
7227             }
7228              
7229             # $$foo[ ... ] --> $ $foo->[ ... ]
7230             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7231 0         0 $char[$i] = e_capture($1.'->'.$2);
7232 0 0       0 if ($ignorecase) {
7233 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7234             }
7235             }
7236              
7237             # $$foo{ ... } --> $ $foo->{ ... }
7238             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7239 0         0 $char[$i] = e_capture($1.'->'.$2);
7240 0 0       0 if ($ignorecase) {
7241 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7242             }
7243             }
7244              
7245             # $$foo
7246             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7247 0         0 $char[$i] = e_capture($1);
7248 0 0       0 if ($ignorecase) {
7249 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7250             }
7251             }
7252              
7253             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
7254             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7255 12 50       24 if ($ignorecase) {
7256 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::PREMATCH())]}';
7257             }
7258             else {
7259 12         90 $char[$i] = '@{[Elatin1::PREMATCH()]}';
7260             }
7261             }
7262              
7263             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
7264             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7265 12 50       24 if ($ignorecase) {
7266 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::MATCH())]}';
7267             }
7268             else {
7269 12         82 $char[$i] = '@{[Elatin1::MATCH()]}';
7270             }
7271             }
7272              
7273             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
7274             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7275 9 50       16 if ($ignorecase) {
7276 0         0 $char[$i] = '@{[Elatin1::ignorecase(Elatin1::POSTMATCH())]}';
7277             }
7278             else {
7279 9         61 $char[$i] = '@{[Elatin1::POSTMATCH()]}';
7280             }
7281             }
7282              
7283             # ${ foo }
7284             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7285 0 0       0 if ($ignorecase) {
7286 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $1 . ')]}';
7287             }
7288             }
7289              
7290             # ${ ... }
7291             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7292 0         0 $char[$i] = e_capture($1);
7293 0 0       0 if ($ignorecase) {
7294 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7295             }
7296             }
7297              
7298             # $scalar or @array
7299             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7300 3         9 $char[$i] = e_string($char[$i]);
7301 3 50       28 if ($ignorecase) {
7302 0         0 $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7303             }
7304             }
7305              
7306             # quote character before ? + * {
7307             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7308 1 50       9 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7309             }
7310             else {
7311 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7312             }
7313             }
7314             }
7315              
7316             # make regexp string
7317 74         113 $modifier =~ tr/i//d;
7318 74 50       166 if ($left_e > $right_e) {
7319 0         0 return join '', 'Elatin1::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7320             }
7321 74         724 return join '', 'Elatin1::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7322             }
7323              
7324             #
7325             # escape regexp of split qr''
7326             #
7327             sub e_split_q {
7328 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7329 0   0       $modifier ||= '';
7330              
7331 0           $modifier =~ tr/p//d;
7332 0 0         if ($modifier =~ /([adlu])/oxms) {
7333 0           my $line = 0;
7334 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7335 0 0         if ($filename ne __FILE__) {
7336 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7337 0           last;
7338             }
7339             }
7340 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7341             }
7342              
7343 0           $slash = 'div';
7344              
7345             # /b /B modifier
7346 0 0         if ($modifier =~ tr/bB//d) {
7347 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7348             }
7349              
7350 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7351              
7352             # split regexp
7353 0           my @char = $string =~ /\G((?>
7354             [^\\\[] |
7355             [\x00-\xFF] |
7356             \[\^ |
7357             \[\: (?>[a-z]+) \:\] |
7358             \[\:\^ (?>[a-z]+) \:\] |
7359             \\ (?:$q_char) |
7360             (?:$q_char)
7361             ))/oxmsg;
7362              
7363             # unescape character
7364 0           for (my $i=0; $i <= $#char; $i++) {
7365 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7366             }
7367              
7368             # open character class [...]
7369 0           elsif ($char[$i] eq '[') {
7370 0           my $left = $i;
7371 0 0         if ($char[$i+1] eq ']') {
7372 0           $i++;
7373             }
7374 0           while (1) {
7375 0 0         if (++$i > $#char) {
7376 0           die __FILE__, ": Unmatched [] in regexp\n";
7377             }
7378 0 0         if ($char[$i] eq ']') {
7379 0           my $right = $i;
7380              
7381             # [...]
7382 0           splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
7383              
7384 0           $i = $left;
7385 0           last;
7386             }
7387             }
7388             }
7389              
7390             # open character class [^...]
7391             elsif ($char[$i] eq '[^') {
7392 0           my $left = $i;
7393 0 0         if ($char[$i+1] eq ']') {
7394 0           $i++;
7395             }
7396 0           while (1) {
7397 0 0         if (++$i > $#char) {
7398 0           die __FILE__, ": Unmatched [] in regexp\n";
7399             }
7400 0 0         if ($char[$i] eq ']') {
7401 0           my $right = $i;
7402              
7403             # [^...]
7404 0           splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7405              
7406 0           $i = $left;
7407 0           last;
7408             }
7409             }
7410             }
7411              
7412             # rewrite character class or escape character
7413             elsif (my $char = character_class($char[$i],$modifier)) {
7414 0           $char[$i] = $char;
7415             }
7416              
7417             # split(m/^/) --> split(m/^/m)
7418             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7419 0           $modifier .= 'm';
7420             }
7421              
7422             # /i modifier
7423             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
7424 0 0         if (CORE::length(Elatin1::fc($char[$i])) == 1) {
7425 0           $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
7426             }
7427             else {
7428 0           $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
7429             }
7430             }
7431              
7432             # quote character before ? + * {
7433             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7434 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7435             }
7436             else {
7437 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7438             }
7439             }
7440             }
7441              
7442 0           $modifier =~ tr/i//d;
7443 0           return join '', 'Elatin1::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7444             }
7445              
7446             #
7447             # instead of Carp::carp
7448             #
7449             sub carp {
7450 0     0 0   my($package,$filename,$line) = caller(1);
7451 0           print STDERR "@_ at $filename line $line.\n";
7452             }
7453              
7454             #
7455             # instead of Carp::croak
7456             #
7457             sub croak {
7458 0     0 0   my($package,$filename,$line) = caller(1);
7459 0           print STDERR "@_ at $filename line $line.\n";
7460 0           die "\n";
7461             }
7462              
7463             #
7464             # instead of Carp::cluck
7465             #
7466             sub cluck {
7467 0     0 0   my $i = 0;
7468 0           my @cluck = ();
7469 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7470 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7471 0           $i++;
7472             }
7473 0           print STDERR CORE::reverse @cluck;
7474 0           print STDERR "\n";
7475 0           carp @_;
7476             }
7477              
7478             #
7479             # instead of Carp::confess
7480             #
7481             sub confess {
7482 0     0 0   my $i = 0;
7483 0           my @confess = ();
7484 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7485 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7486 0           $i++;
7487             }
7488 0           print STDERR CORE::reverse @confess;
7489 0           print STDERR "\n";
7490 0           croak @_;
7491             }
7492              
7493             1;
7494              
7495             __END__