File Coverage

blib/lib/Elatin1.pm
Criterion Covered Total %
statement 905 3196 28.3
branch 968 2742 35.3
condition 98 355 27.6
subroutine 52 110 47.2
pod 7 74 9.4
total 2030 6477 31.3


line stmt bran cond sub pod time code
1             package Elatin1;
2 204     204   1461 use strict;
  204         325  
  204         7079  
3             ######################################################################
4             #
5             # Elatin1 - Run-time routines for Latin1.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin1/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   2949 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         883  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 204     204   2153 use vars qw($VERSION);
  204         440  
  204         32644  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1800 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         353 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         31073 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44              
45             # instead of utf8.pm
46 204     204   15228 CORE::eval q{
  204     204   1403  
  204     82   401  
  204         22987  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 204 50       100969 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     0 0 0 my($name) = @_;
78              
79 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
80 0         0 return $name;
81             }
82             elsif (Elatin1::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Elatin1::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 0         0 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 0   0 0 0 if (defined $_[1]) {
117 204     204   2676 no strict qw(refs);
  204         372  
  204         20346  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   1384 no strict qw(refs);
  204     0   575  
  204         38835  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x00-\xFF]};
153 204     204   1290 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         386  
  204         15469  
154 204     204   1417 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         754  
  204         367347  
155              
156             #
157             # Latin-1 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Latin-1 case conversion
163             #
164             my %lc = ();
165             @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)} =
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 %uc = ();
168             @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)} =
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             my %fc = ();
171             @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)} =
172             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);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Elatin1 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
185             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
186             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
187             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
188             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
189             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
190             "\xC6" => "\xE6", # LATIN LETTER AE
191             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
192             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
193             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
194             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
195             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
196             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
197             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
198             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
199             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
200             "\xD0" => "\xF0", # LATIN LETTER ETH (Icelandic)
201             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
202             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
203             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
204             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
205             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
206             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
207             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
208             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
209             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
210             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
211             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
212             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
213             "\xDE" => "\xFE", # LATIN LETTER THORN (Icelandic)
214             );
215              
216             %uc = (%uc,
217             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
218             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
219             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
220             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
221             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
222             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
223             "\xE6" => "\xC6", # LATIN LETTER AE
224             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
225             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
226             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
227             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
228             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
229             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
230             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
231             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
232             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
233             "\xF0" => "\xD0", # LATIN LETTER ETH (Icelandic)
234             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
235             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
236             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
237             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
238             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
239             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
240             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
241             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
242             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
243             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
244             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
245             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
246             "\xFE" => "\xDE", # LATIN LETTER THORN (Icelandic)
247             );
248              
249             %fc = (%fc,
250             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
251             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
252             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
253             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
254             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
255             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
256             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
257             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
258             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
259             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
260             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
261             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
262             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
263             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
264             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
265             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
266             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
267             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
268             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
269             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
270             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
271             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
272             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
273             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
274             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
275             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
276             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
277             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
278             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
279             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
280             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
281             );
282             }
283              
284             else {
285             croak "Don't know my package name '@{[__PACKAGE__]}'";
286             }
287              
288             #
289             # @ARGV wildcard globbing
290             #
291             sub import {
292              
293 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
294 0         0 my @argv = ();
295 0         0 for (@ARGV) {
296              
297             # has space
298 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
299 0 0       0 if (my @glob = Elatin1::glob(qq{"$_"})) {
300 0         0 push @argv, @glob;
301             }
302             else {
303 0         0 push @argv, $_;
304             }
305             }
306              
307             # has wildcard metachar
308             elsif (/\A (?:$q_char)*? [*?] /oxms) {
309 0 0       0 if (my @glob = Elatin1::glob($_)) {
310 0         0 push @argv, @glob;
311             }
312             else {
313 0         0 push @argv, $_;
314             }
315             }
316              
317             # no wildcard globbing
318             else {
319 0         0 push @argv, $_;
320             }
321             }
322 0         0 @ARGV = @argv;
323             }
324              
325 0         0 *Char::ord = \&Latin1::ord;
326 0         0 *Char::ord_ = \&Latin1::ord_;
327 0         0 *Char::reverse = \&Latin1::reverse;
328 0         0 *Char::getc = \&Latin1::getc;
329 0         0 *Char::length = \&Latin1::length;
330 0         0 *Char::substr = \&Latin1::substr;
331 0         0 *Char::index = \&Latin1::index;
332 0         0 *Char::rindex = \&Latin1::rindex;
333 0         0 *Char::eval = \&Latin1::eval;
334 0         0 *Char::escape = \&Latin1::escape;
335 0         0 *Char::escape_token = \&Latin1::escape_token;
336 0         0 *Char::escape_script = \&Latin1::escape_script;
337             }
338              
339             # P.230 Care with Prototypes
340             # in Chapter 6: Subroutines
341             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
342             #
343             # If you aren't careful, you can get yourself into trouble with prototypes.
344             # But if you are careful, you can do a lot of neat things with them. This is
345             # all very powerful, of course, and should only be used in moderation to make
346             # the world a better place.
347              
348             # P.332 Care with Prototypes
349             # in Chapter 7: Subroutines
350             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
351             #
352             # If you aren't careful, you can get yourself into trouble with prototypes.
353             # But if you are careful, you can do a lot of neat things with them. This is
354             # all very powerful, of course, and should only be used in moderation to make
355             # the world a better place.
356              
357             #
358             # Prototypes of subroutines
359             #
360       0     sub unimport {}
361             sub Elatin1::split(;$$$);
362             sub Elatin1::tr($$$$;$);
363             sub Elatin1::chop(@);
364             sub Elatin1::index($$;$);
365             sub Elatin1::rindex($$;$);
366             sub Elatin1::lcfirst(@);
367             sub Elatin1::lcfirst_();
368             sub Elatin1::lc(@);
369             sub Elatin1::lc_();
370             sub Elatin1::ucfirst(@);
371             sub Elatin1::ucfirst_();
372             sub Elatin1::uc(@);
373             sub Elatin1::uc_();
374             sub Elatin1::fc(@);
375             sub Elatin1::fc_();
376             sub Elatin1::ignorecase;
377             sub Elatin1::classic_character_class;
378             sub Elatin1::capture;
379             sub Elatin1::chr(;$);
380             sub Elatin1::chr_();
381             sub Elatin1::glob($);
382             sub Elatin1::glob_();
383              
384             sub Latin1::ord(;$);
385             sub Latin1::ord_();
386             sub Latin1::reverse(@);
387             sub Latin1::getc(;*@);
388             sub Latin1::length(;$);
389             sub Latin1::substr($$;$$);
390             sub Latin1::index($$;$);
391             sub Latin1::rindex($$;$);
392             sub Latin1::escape(;$);
393              
394             #
395             # Regexp work
396             #
397 204         16394 use vars qw(
398             $re_a
399             $re_t
400             $re_n
401             $re_r
402 204     204   2441 );
  204         403  
403              
404             #
405             # Character class
406             #
407 204         2292198 use vars qw(
408             $dot
409             $dot_s
410             $eD
411             $eS
412             $eW
413             $eH
414             $eV
415             $eR
416             $eN
417             $not_alnum
418             $not_alpha
419             $not_ascii
420             $not_blank
421             $not_cntrl
422             $not_digit
423             $not_graph
424             $not_lower
425             $not_lower_i
426             $not_print
427             $not_punct
428             $not_space
429             $not_upper
430             $not_upper_i
431             $not_word
432             $not_xdigit
433             $eb
434             $eB
435 204     204   1184 );
  204         402  
436              
437             ${Elatin1::dot} = qr{(?>[^\x0A])};
438             ${Elatin1::dot_s} = qr{(?>[\x00-\xFF])};
439             ${Elatin1::eD} = qr{(?>[^0-9])};
440              
441             # Vertical tabs are now whitespace
442             # \s in a regex now matches a vertical tab in all circumstances.
443             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
444             # ${Elatin1::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
445             # ${Elatin1::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
446             ${Elatin1::eS} = qr{(?>[^\s])};
447              
448             ${Elatin1::eW} = qr{(?>[^0-9A-Z_a-z])};
449             ${Elatin1::eH} = qr{(?>[^\x09\x20])};
450             ${Elatin1::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
451             ${Elatin1::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
452             ${Elatin1::eN} = qr{(?>[^\x0A])};
453             ${Elatin1::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
454             ${Elatin1::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
455             ${Elatin1::not_ascii} = qr{(?>[^\x00-\x7F])};
456             ${Elatin1::not_blank} = qr{(?>[^\x09\x20])};
457             ${Elatin1::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
458             ${Elatin1::not_digit} = qr{(?>[^\x30-\x39])};
459             ${Elatin1::not_graph} = qr{(?>[^\x21-\x7F])};
460             ${Elatin1::not_lower} = qr{(?>[^\x61-\x7A])};
461             ${Elatin1::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
462             # ${Elatin1::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
463             ${Elatin1::not_print} = qr{(?>[^\x20-\x7F])};
464             ${Elatin1::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
465             ${Elatin1::not_space} = qr{(?>[^\s\x0B])};
466             ${Elatin1::not_upper} = qr{(?>[^\x41-\x5A])};
467             ${Elatin1::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
468             # ${Elatin1::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
469             ${Elatin1::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
470             ${Elatin1::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
471             ${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))};
472             ${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]))};
473              
474             # avoid: Name "Elatin1::foo" used only once: possible typo at here.
475             ${Elatin1::dot} = ${Elatin1::dot};
476             ${Elatin1::dot_s} = ${Elatin1::dot_s};
477             ${Elatin1::eD} = ${Elatin1::eD};
478             ${Elatin1::eS} = ${Elatin1::eS};
479             ${Elatin1::eW} = ${Elatin1::eW};
480             ${Elatin1::eH} = ${Elatin1::eH};
481             ${Elatin1::eV} = ${Elatin1::eV};
482             ${Elatin1::eR} = ${Elatin1::eR};
483             ${Elatin1::eN} = ${Elatin1::eN};
484             ${Elatin1::not_alnum} = ${Elatin1::not_alnum};
485             ${Elatin1::not_alpha} = ${Elatin1::not_alpha};
486             ${Elatin1::not_ascii} = ${Elatin1::not_ascii};
487             ${Elatin1::not_blank} = ${Elatin1::not_blank};
488             ${Elatin1::not_cntrl} = ${Elatin1::not_cntrl};
489             ${Elatin1::not_digit} = ${Elatin1::not_digit};
490             ${Elatin1::not_graph} = ${Elatin1::not_graph};
491             ${Elatin1::not_lower} = ${Elatin1::not_lower};
492             ${Elatin1::not_lower_i} = ${Elatin1::not_lower_i};
493             ${Elatin1::not_print} = ${Elatin1::not_print};
494             ${Elatin1::not_punct} = ${Elatin1::not_punct};
495             ${Elatin1::not_space} = ${Elatin1::not_space};
496             ${Elatin1::not_upper} = ${Elatin1::not_upper};
497             ${Elatin1::not_upper_i} = ${Elatin1::not_upper_i};
498             ${Elatin1::not_word} = ${Elatin1::not_word};
499             ${Elatin1::not_xdigit} = ${Elatin1::not_xdigit};
500             ${Elatin1::eb} = ${Elatin1::eb};
501             ${Elatin1::eB} = ${Elatin1::eB};
502              
503             #
504             # Latin-1 split
505             #
506             sub Elatin1::split(;$$$) {
507              
508             # P.794 29.2.161. split
509             # in Chapter 29: Functions
510             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
511              
512             # P.951 split
513             # in Chapter 27: Functions
514             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
515              
516 0     0 0 0 my $pattern = $_[0];
517 0         0 my $string = $_[1];
518 0         0 my $limit = $_[2];
519              
520             # if $pattern is also omitted or is the literal space, " "
521 0 0       0 if (not defined $pattern) {
522 0         0 $pattern = ' ';
523             }
524              
525             # if $string is omitted, the function splits the $_ string
526 0 0       0 if (not defined $string) {
527 0 0       0 if (defined $_) {
528 0         0 $string = $_;
529             }
530             else {
531 0         0 $string = '';
532             }
533             }
534              
535 0         0 my @split = ();
536              
537             # when string is empty
538 0 0       0 if ($string eq '') {
    0          
539              
540             # resulting list value in list context
541 0 0       0 if (wantarray) {
542 0         0 return @split;
543             }
544              
545             # count of substrings in scalar context
546             else {
547 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
548 0         0 @_ = @split;
549 0         0 return scalar @_;
550             }
551             }
552              
553             # split's first argument is more consistently interpreted
554             #
555             # After some changes earlier in v5.17, split's behavior has been simplified:
556             # if the PATTERN argument evaluates to a string containing one space, it is
557             # treated the way that a literal string containing one space once was.
558             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
559              
560             # if $pattern is also omitted or is the literal space, " ", the function splits
561             # on whitespace, /\s+/, after skipping any leading whitespace
562             # (and so on)
563              
564             elsif ($pattern eq ' ') {
565 0 0       0 if (not defined $limit) {
566 0         0 return CORE::split(' ', $string);
567             }
568             else {
569 0         0 return CORE::split(' ', $string, $limit);
570             }
571             }
572              
573             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
574 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
575              
576             # a pattern capable of matching either the null string or something longer than the
577             # null string will split the value of $string into separate characters wherever it
578             # matches the null string between characters
579             # (and so on)
580              
581 0 0       0 if ('' =~ / \A $pattern \z /xms) {
582 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
583 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
584              
585             # P.1024 Appendix W.10 Multibyte Processing
586             # of ISBN 1-56592-224-7 CJKV Information Processing
587             # (and so on)
588              
589             # the //m modifier is assumed when you split on the pattern /^/
590             # (and so on)
591              
592             # V
593 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
594              
595             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
596             # is included in the resulting list, interspersed with the fields that are ordinarily returned
597             # (and so on)
598              
599 0         0 local $@;
600 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
601 0         0 push @split, CORE::eval('$' . $digit);
602             }
603             }
604             }
605              
606             else {
607 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
608              
609             # V
610 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
611 0         0 local $@;
612 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
613 0         0 push @split, CORE::eval('$' . $digit);
614             }
615             }
616             }
617             }
618              
619             elsif ($limit > 0) {
620 0 0       0 if ('' =~ / \A $pattern \z /xms) {
621 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
622 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
623              
624             # V
625 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
626 0         0 local $@;
627 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
628 0         0 push @split, CORE::eval('$' . $digit);
629             }
630             }
631             }
632             }
633             else {
634 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
635 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
636              
637             # V
638 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
639 0         0 local $@;
640 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
641 0         0 push @split, CORE::eval('$' . $digit);
642             }
643             }
644             }
645             }
646             }
647              
648 0 0       0 if (CORE::length($string) > 0) {
649 0         0 push @split, $string;
650             }
651              
652             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
653 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
654 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
655 0         0 pop @split;
656             }
657             }
658              
659             # resulting list value in list context
660 0 0       0 if (wantarray) {
661 0         0 return @split;
662             }
663              
664             # count of substrings in scalar context
665             else {
666 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
667 0         0 @_ = @split;
668 0         0 return scalar @_;
669             }
670             }
671              
672             #
673             # get last subexpression offsets
674             #
675             sub _last_subexpression_offsets {
676 0     0   0 my $pattern = $_[0];
677              
678             # remove comment
679 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
680              
681 0         0 my $modifier = '';
682 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
683 0         0 $modifier = $1;
684 0         0 $modifier =~ s/-[A-Za-z]*//;
685             }
686              
687             # with /x modifier
688 0         0 my @char = ();
689 0 0       0 if ($modifier =~ /x/oxms) {
690 0         0 @char = $pattern =~ /\G((?>
691             [^\\\#\[\(] |
692             \\ $q_char |
693             \# (?>[^\n]*) $ |
694             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
695             \(\? |
696             $q_char
697             ))/oxmsg;
698             }
699              
700             # without /x modifier
701             else {
702 0         0 @char = $pattern =~ /\G((?>
703             [^\\\[\(] |
704             \\ $q_char |
705             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
706             \(\? |
707             $q_char
708             ))/oxmsg;
709             }
710              
711 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
712             }
713              
714             #
715             # Latin-1 transliteration (tr///)
716             #
717             sub Elatin1::tr($$$$;$) {
718              
719 0     0 0 0 my $bind_operator = $_[1];
720 0         0 my $searchlist = $_[2];
721 0         0 my $replacementlist = $_[3];
722 0   0     0 my $modifier = $_[4] || '';
723              
724 0 0       0 if ($modifier =~ /r/oxms) {
725 0 0       0 if ($bind_operator =~ / !~ /oxms) {
726 0         0 croak "Using !~ with tr///r doesn't make sense";
727             }
728             }
729              
730 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
731 0         0 my @searchlist = _charlist_tr($searchlist);
732 0         0 my @replacementlist = _charlist_tr($replacementlist);
733              
734 0         0 my %tr = ();
735 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
736 0 0       0 if (not exists $tr{$searchlist[$i]}) {
737 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
738 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
739             }
740             elsif ($modifier =~ /d/oxms) {
741 0         0 $tr{$searchlist[$i]} = '';
742             }
743             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
744 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
745             }
746             else {
747 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
748             }
749             }
750             }
751              
752 0         0 my $tr = 0;
753 0         0 my $replaced = '';
754 0 0       0 if ($modifier =~ /c/oxms) {
755 0         0 while (defined(my $char = shift @char)) {
756 0 0       0 if (not exists $tr{$char}) {
757 0 0       0 if (defined $replacementlist[0]) {
758 0         0 $replaced .= $replacementlist[0];
759             }
760 0         0 $tr++;
761 0 0       0 if ($modifier =~ /s/oxms) {
762 0   0     0 while (@char and (not exists $tr{$char[0]})) {
763 0         0 shift @char;
764 0         0 $tr++;
765             }
766             }
767             }
768             else {
769 0         0 $replaced .= $char;
770             }
771             }
772             }
773             else {
774 0         0 while (defined(my $char = shift @char)) {
775 0 0       0 if (exists $tr{$char}) {
776 0         0 $replaced .= $tr{$char};
777 0         0 $tr++;
778 0 0       0 if ($modifier =~ /s/oxms) {
779 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
780 0         0 shift @char;
781 0         0 $tr++;
782             }
783             }
784             }
785             else {
786 0         0 $replaced .= $char;
787             }
788             }
789             }
790              
791 0 0       0 if ($modifier =~ /r/oxms) {
792 0         0 return $replaced;
793             }
794             else {
795 0         0 $_[0] = $replaced;
796 0 0       0 if ($bind_operator =~ / !~ /oxms) {
797 0         0 return not $tr;
798             }
799             else {
800 0         0 return $tr;
801             }
802             }
803             }
804              
805             #
806             # Latin-1 chop
807             #
808             sub Elatin1::chop(@) {
809              
810 0     0 0 0 my $chop;
811 0 0       0 if (@_ == 0) {
812 0         0 my @char = /\G (?>$q_char) /oxmsg;
813 0         0 $chop = pop @char;
814 0         0 $_ = join '', @char;
815             }
816             else {
817 0         0 for (@_) {
818 0         0 my @char = /\G (?>$q_char) /oxmsg;
819 0         0 $chop = pop @char;
820 0         0 $_ = join '', @char;
821             }
822             }
823 0         0 return $chop;
824             }
825              
826             #
827             # Latin-1 index by octet
828             #
829             sub Elatin1::index($$;$) {
830              
831 0     0 1 0 my($str,$substr,$position) = @_;
832 0   0     0 $position ||= 0;
833 0         0 my $pos = 0;
834              
835 0         0 while ($pos < CORE::length($str)) {
836 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
837 0 0       0 if ($pos >= $position) {
838 0         0 return $pos;
839             }
840             }
841 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
842 0         0 $pos += CORE::length($1);
843             }
844             else {
845 0         0 $pos += 1;
846             }
847             }
848 0         0 return -1;
849             }
850              
851             #
852             # Latin-1 reverse index
853             #
854             sub Elatin1::rindex($$;$) {
855              
856 0     0 0 0 my($str,$substr,$position) = @_;
857 0   0     0 $position ||= CORE::length($str) - 1;
858 0         0 my $pos = 0;
859 0         0 my $rindex = -1;
860              
861 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
862 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
863 0         0 $rindex = $pos;
864             }
865 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
866 0         0 $pos += CORE::length($1);
867             }
868             else {
869 0         0 $pos += 1;
870             }
871             }
872 0         0 return $rindex;
873             }
874              
875             #
876             # Latin-1 lower case first with parameter
877             #
878             sub Elatin1::lcfirst(@) {
879 0 0   0 0 0 if (@_) {
880 0         0 my $s = shift @_;
881 0 0 0     0 if (@_ and wantarray) {
882 0         0 return Elatin1::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
883             }
884             else {
885 0         0 return Elatin1::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
886             }
887             }
888             else {
889 0         0 return Elatin1::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
890             }
891             }
892              
893             #
894             # Latin-1 lower case first without parameter
895             #
896             sub Elatin1::lcfirst_() {
897 0     0 0 0 return Elatin1::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
898             }
899              
900             #
901             # Latin-1 lower case with parameter
902             #
903             sub Elatin1::lc(@) {
904 0 0   0 0 0 if (@_) {
905 0         0 my $s = shift @_;
906 0 0 0     0 if (@_ and wantarray) {
907 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
908             }
909             else {
910 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
911             }
912             }
913             else {
914 0         0 return Elatin1::lc_();
915             }
916             }
917              
918             #
919             # Latin-1 lower case without parameter
920             #
921             sub Elatin1::lc_() {
922 0     0 0 0 my $s = $_;
923 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
924             }
925              
926             #
927             # Latin-1 upper case first with parameter
928             #
929             sub Elatin1::ucfirst(@) {
930 0 0   0 0 0 if (@_) {
931 0         0 my $s = shift @_;
932 0 0 0     0 if (@_ and wantarray) {
933 0         0 return Elatin1::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
934             }
935             else {
936 0         0 return Elatin1::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
937             }
938             }
939             else {
940 0         0 return Elatin1::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
941             }
942             }
943              
944             #
945             # Latin-1 upper case first without parameter
946             #
947             sub Elatin1::ucfirst_() {
948 0     0 0 0 return Elatin1::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
949             }
950              
951             #
952             # Latin-1 upper case with parameter
953             #
954             sub Elatin1::uc(@) {
955 0 50   174 0 0 if (@_) {
956 174         319 my $s = shift @_;
957 174 50 33     243 if (@_ and wantarray) {
958 174 0       306 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
959             }
960             else {
961 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         536  
962             }
963             }
964             else {
965 174         609 return Elatin1::uc_();
966             }
967             }
968              
969             #
970             # Latin-1 upper case without parameter
971             #
972             sub Elatin1::uc_() {
973 0     0 0 0 my $s = $_;
974 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
975             }
976              
977             #
978             # Latin-1 fold case with parameter
979             #
980             sub Elatin1::fc(@) {
981 0 50   197 0 0 if (@_) {
982 197         271 my $s = shift @_;
983 197 50 33     216 if (@_ and wantarray) {
984 197 0       332 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
985             }
986             else {
987 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         477  
988             }
989             }
990             else {
991 197         1004 return Elatin1::fc_();
992             }
993             }
994              
995             #
996             # Latin-1 fold case without parameter
997             #
998             sub Elatin1::fc_() {
999 0     0 0 0 my $s = $_;
1000 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1001             }
1002              
1003             #
1004             # Latin-1 regexp capture
1005             #
1006             {
1007             sub Elatin1::capture {
1008 0     0 1 0 return $_[0];
1009             }
1010             }
1011              
1012             #
1013             # Latin-1 regexp ignore case modifier
1014             #
1015             sub Elatin1::ignorecase {
1016              
1017 0     0 0 0 my @string = @_;
1018 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1019              
1020             # ignore case of $scalar or @array
1021 0         0 for my $string (@string) {
1022              
1023             # split regexp
1024 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1025              
1026             # unescape character
1027 0         0 for (my $i=0; $i <= $#char; $i++) {
1028 0 0       0 next if not defined $char[$i];
1029              
1030             # open character class [...]
1031 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1032 0         0 my $left = $i;
1033              
1034             # [] make die "unmatched [] in regexp ...\n"
1035              
1036 0 0       0 if ($char[$i+1] eq ']') {
1037 0         0 $i++;
1038             }
1039              
1040 0         0 while (1) {
1041 0 0       0 if (++$i > $#char) {
1042 0         0 croak "Unmatched [] in regexp";
1043             }
1044 0 0       0 if ($char[$i] eq ']') {
1045 0         0 my $right = $i;
1046 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1047              
1048             # escape character
1049 0         0 for my $char (@charlist) {
1050 0 0       0 if (0) {
1051             }
1052              
1053 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1054 0         0 $char = '\\' . $char;
1055             }
1056             }
1057              
1058             # [...]
1059 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1060              
1061 0         0 $i = $left;
1062 0         0 last;
1063             }
1064             }
1065             }
1066              
1067             # open character class [^...]
1068             elsif ($char[$i] eq '[^') {
1069 0         0 my $left = $i;
1070              
1071             # [^] make die "unmatched [] in regexp ...\n"
1072              
1073 0 0       0 if ($char[$i+1] eq ']') {
1074 0         0 $i++;
1075             }
1076              
1077 0         0 while (1) {
1078 0 0       0 if (++$i > $#char) {
1079 0         0 croak "Unmatched [] in regexp";
1080             }
1081 0 0       0 if ($char[$i] eq ']') {
1082 0         0 my $right = $i;
1083 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1084              
1085             # escape character
1086 0         0 for my $char (@charlist) {
1087 0 0       0 if (0) {
1088             }
1089              
1090 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1091 0         0 $char = '\\' . $char;
1092             }
1093             }
1094              
1095             # [^...]
1096 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1097              
1098 0         0 $i = $left;
1099 0         0 last;
1100             }
1101             }
1102             }
1103              
1104             # rewrite classic character class or escape character
1105             elsif (my $char = classic_character_class($char[$i])) {
1106 0         0 $char[$i] = $char;
1107             }
1108              
1109             # with /i modifier
1110             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1111 0         0 my $uc = Elatin1::uc($char[$i]);
1112 0         0 my $fc = Elatin1::fc($char[$i]);
1113 0 0       0 if ($uc ne $fc) {
1114 0 0       0 if (CORE::length($fc) == 1) {
1115 0         0 $char[$i] = '[' . $uc . $fc . ']';
1116             }
1117             else {
1118 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1119             }
1120             }
1121             }
1122             }
1123              
1124             # characterize
1125 0         0 for (my $i=0; $i <= $#char; $i++) {
1126 0 0       0 next if not defined $char[$i];
1127              
1128 0 0       0 if (0) {
1129             }
1130              
1131             # quote character before ? + * {
1132 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1133 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1134 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1135             }
1136             }
1137             }
1138              
1139 0         0 $string = join '', @char;
1140             }
1141              
1142             # make regexp string
1143 0         0 return @string;
1144             }
1145              
1146             #
1147             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1148             #
1149             sub Elatin1::classic_character_class {
1150 0     1867 0 0 my($char) = @_;
1151              
1152             return {
1153             '\D' => '${Elatin1::eD}',
1154             '\S' => '${Elatin1::eS}',
1155             '\W' => '${Elatin1::eW}',
1156             '\d' => '[0-9]',
1157              
1158             # Before Perl 5.6, \s only matched the five whitespace characters
1159             # tab, newline, form-feed, carriage return, and the space character
1160             # itself, which, taken together, is the character class [\t\n\f\r ].
1161              
1162             # Vertical tabs are now whitespace
1163             # \s in a regex now matches a vertical tab in all circumstances.
1164             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1165             # \t \n \v \f \r space
1166             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1167             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1168             '\s' => '\s',
1169              
1170             '\w' => '[0-9A-Z_a-z]',
1171             '\C' => '[\x00-\xFF]',
1172             '\X' => 'X',
1173              
1174             # \h \v \H \V
1175              
1176             # P.114 Character Class Shortcuts
1177             # in Chapter 7: In the World of Regular Expressions
1178             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1179              
1180             # P.357 13.2.3 Whitespace
1181             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1182             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1183             #
1184             # 0x00009 CHARACTER TABULATION h s
1185             # 0x0000a LINE FEED (LF) vs
1186             # 0x0000b LINE TABULATION v
1187             # 0x0000c FORM FEED (FF) vs
1188             # 0x0000d CARRIAGE RETURN (CR) vs
1189             # 0x00020 SPACE h s
1190              
1191             # P.196 Table 5-9. Alphanumeric regex metasymbols
1192             # in Chapter 5. Pattern Matching
1193             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1194              
1195             # (and so on)
1196              
1197             '\H' => '${Elatin1::eH}',
1198             '\V' => '${Elatin1::eV}',
1199             '\h' => '[\x09\x20]',
1200             '\v' => '[\x0A\x0B\x0C\x0D]',
1201             '\R' => '${Elatin1::eR}',
1202              
1203             # \N
1204             #
1205             # http://perldoc.perl.org/perlre.html
1206             # Character Classes and other Special Escapes
1207             # Any character but \n (experimental). Not affected by /s modifier
1208              
1209             '\N' => '${Elatin1::eN}',
1210              
1211             # \b \B
1212              
1213             # P.180 Boundaries: The \b and \B Assertions
1214             # in Chapter 5: Pattern Matching
1215             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1216              
1217             # P.219 Boundaries: The \b and \B Assertions
1218             # in Chapter 5: Pattern Matching
1219             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1220              
1221             # \b really means (?:(?<=\w)(?!\w)|(?
1222             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1223             '\b' => '${Elatin1::eb}',
1224              
1225             # \B really means (?:(?<=\w)(?=\w)|(?
1226             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1227             '\B' => '${Elatin1::eB}',
1228              
1229 1867   100     2796 }->{$char} || '';
1230             }
1231              
1232             #
1233             # prepare Latin-1 characters per length
1234             #
1235              
1236             # 1 octet characters
1237             my @chars1 = ();
1238             sub chars1 {
1239 1867 0   0 0 68667 if (@chars1) {
1240 0         0 return @chars1;
1241             }
1242 0 0       0 if (exists $range_tr{1}) {
1243 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1244 0         0 while (my @range = splice(@ranges,0,1)) {
1245 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1246 0         0 push @chars1, pack 'C', $oct0;
1247             }
1248             }
1249             }
1250 0         0 return @chars1;
1251             }
1252              
1253             # 2 octets characters
1254             my @chars2 = ();
1255             sub chars2 {
1256 0 0   0 0 0 if (@chars2) {
1257 0         0 return @chars2;
1258             }
1259 0 0       0 if (exists $range_tr{2}) {
1260 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1261 0         0 while (my @range = splice(@ranges,0,2)) {
1262 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1263 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1264 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1265             }
1266             }
1267             }
1268             }
1269 0         0 return @chars2;
1270             }
1271              
1272             # 3 octets characters
1273             my @chars3 = ();
1274             sub chars3 {
1275 0 0   0 0 0 if (@chars3) {
1276 0         0 return @chars3;
1277             }
1278 0 0       0 if (exists $range_tr{3}) {
1279 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1280 0         0 while (my @range = splice(@ranges,0,3)) {
1281 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1282 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1283 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1284 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1285             }
1286             }
1287             }
1288             }
1289             }
1290 0         0 return @chars3;
1291             }
1292              
1293             # 4 octets characters
1294             my @chars4 = ();
1295             sub chars4 {
1296 0 0   0 0 0 if (@chars4) {
1297 0         0 return @chars4;
1298             }
1299 0 0       0 if (exists $range_tr{4}) {
1300 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1301 0         0 while (my @range = splice(@ranges,0,4)) {
1302 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1303 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1304 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1305 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1306 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1307             }
1308             }
1309             }
1310             }
1311             }
1312             }
1313 0         0 return @chars4;
1314             }
1315              
1316             #
1317             # Latin-1 open character list for tr
1318             #
1319             sub _charlist_tr {
1320              
1321 0     0   0 local $_ = shift @_;
1322              
1323             # unescape character
1324 0         0 my @char = ();
1325 0         0 while (not /\G \z/oxmsgc) {
1326 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1327 0         0 push @char, '\-';
1328             }
1329             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1330 0         0 push @char, CORE::chr(oct $1);
1331             }
1332             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1333 0         0 push @char, CORE::chr(hex $1);
1334             }
1335             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1336 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1337             }
1338             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1339             push @char, {
1340             '\0' => "\0",
1341             '\n' => "\n",
1342             '\r' => "\r",
1343             '\t' => "\t",
1344             '\f' => "\f",
1345             '\b' => "\x08", # \b means backspace in character class
1346             '\a' => "\a",
1347             '\e' => "\e",
1348 0         0 }->{$1};
1349             }
1350             elsif (/\G \\ ($q_char) /oxmsgc) {
1351 0         0 push @char, $1;
1352             }
1353             elsif (/\G ($q_char) /oxmsgc) {
1354 0         0 push @char, $1;
1355             }
1356             }
1357              
1358             # join separated multiple-octet
1359 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1360              
1361             # unescape '-'
1362 0         0 my @i = ();
1363 0         0 for my $i (0 .. $#char) {
1364 0 0       0 if ($char[$i] eq '\-') {
    0          
1365 0         0 $char[$i] = '-';
1366             }
1367             elsif ($char[$i] eq '-') {
1368 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1369 0         0 push @i, $i;
1370             }
1371             }
1372             }
1373              
1374             # open character list (reverse for splice)
1375 0         0 for my $i (CORE::reverse @i) {
1376 0         0 my @range = ();
1377              
1378             # range error
1379 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1380 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1381             }
1382              
1383             # range of multiple-octet code
1384 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1385 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1386 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1387             }
1388             elsif (CORE::length($char[$i+1]) == 2) {
1389 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1390 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1391             }
1392             elsif (CORE::length($char[$i+1]) == 3) {
1393 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1394 0         0 push @range, chars2();
1395 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1396             }
1397             elsif (CORE::length($char[$i+1]) == 4) {
1398 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1399 0         0 push @range, chars2();
1400 0         0 push @range, chars3();
1401 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1402             }
1403             else {
1404 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1405             }
1406             }
1407             elsif (CORE::length($char[$i-1]) == 2) {
1408 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1409 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1410             }
1411             elsif (CORE::length($char[$i+1]) == 3) {
1412 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1413 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1414             }
1415             elsif (CORE::length($char[$i+1]) == 4) {
1416 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1417 0         0 push @range, chars3();
1418 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1419             }
1420             else {
1421 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1422             }
1423             }
1424             elsif (CORE::length($char[$i-1]) == 3) {
1425 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1426 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1427             }
1428             elsif (CORE::length($char[$i+1]) == 4) {
1429 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1430 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1431             }
1432             else {
1433 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1434             }
1435             }
1436             elsif (CORE::length($char[$i-1]) == 4) {
1437 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1438 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1439             }
1440             else {
1441 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1442             }
1443             }
1444             else {
1445 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1446             }
1447              
1448 0         0 splice @char, $i-1, 3, @range;
1449             }
1450              
1451 0         0 return @char;
1452             }
1453              
1454             #
1455             # Latin-1 open character class
1456             #
1457             sub _cc {
1458 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1459 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1460             }
1461             elsif (scalar(@_) == 1) {
1462 0         0 return sprintf('\x%02X',$_[0]);
1463             }
1464             elsif (scalar(@_) == 2) {
1465 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1466 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1467             }
1468             elsif ($_[0] == $_[1]) {
1469 0         0 return sprintf('\x%02X',$_[0]);
1470             }
1471             elsif (($_[0]+1) == $_[1]) {
1472 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1473             }
1474             else {
1475 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1476             }
1477             }
1478             else {
1479 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1480             }
1481             }
1482              
1483             #
1484             # Latin-1 octet range
1485             #
1486             sub _octets {
1487 0     182   0 my $length = shift @_;
1488              
1489 182 50       310 if ($length == 1) {
1490 182         356 my($a1) = unpack 'C', $_[0];
1491 182         475 my($z1) = unpack 'C', $_[1];
1492              
1493 182 50       360 if ($a1 > $z1) {
1494 182         356 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1495             }
1496              
1497 0 50       0 if ($a1 == $z1) {
    50          
1498 182         435 return sprintf('\x%02X',$a1);
1499             }
1500             elsif (($a1+1) == $z1) {
1501 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1502             }
1503             else {
1504 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1505             }
1506             }
1507             else {
1508 182         1273 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1509             }
1510             }
1511              
1512             #
1513             # Latin-1 range regexp
1514             #
1515             sub _range_regexp {
1516 0     182   0 my($length,$first,$last) = @_;
1517              
1518 182         371 my @range_regexp = ();
1519 182 50       237 if (not exists $range_tr{$length}) {
1520 182         487 return @range_regexp;
1521             }
1522              
1523 0         0 my @ranges = @{ $range_tr{$length} };
  182         251  
1524 182         403 while (my @range = splice(@ranges,0,$length)) {
1525 182         526 my $min = '';
1526 182         268 my $max = '';
1527 182         231 for (my $i=0; $i < $length; $i++) {
1528 182         471 $min .= pack 'C', $range[$i][0];
1529 182         810 $max .= pack 'C', $range[$i][-1];
1530             }
1531              
1532             # min___max
1533             # FIRST_____________LAST
1534             # (nothing)
1535              
1536 182 50 33     508 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1537             }
1538              
1539             # **********
1540             # min_________max
1541             # FIRST_____________LAST
1542             # **********
1543              
1544             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1545 182         1819 push @range_regexp, _octets($length,$first,$max,$min,$max);
1546             }
1547              
1548             # **********************
1549             # min________________max
1550             # FIRST_____________LAST
1551             # **********************
1552              
1553             elsif (($min eq $first) and ($max eq $last)) {
1554 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1555             }
1556              
1557             # *********
1558             # min___max
1559             # FIRST_____________LAST
1560             # *********
1561              
1562             elsif (($first le $min) and ($max le $last)) {
1563 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1564             }
1565              
1566             # **********************
1567             # min__________________________max
1568             # FIRST_____________LAST
1569             # **********************
1570              
1571             elsif (($min le $first) and ($last le $max)) {
1572 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1573             }
1574              
1575             # *********
1576             # min________max
1577             # FIRST_____________LAST
1578             # *********
1579              
1580             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1581 182         458 push @range_regexp, _octets($length,$min,$last,$min,$max);
1582             }
1583              
1584             # min___max
1585             # FIRST_____________LAST
1586             # (nothing)
1587              
1588             elsif ($last lt $min) {
1589             }
1590              
1591             else {
1592 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1593             }
1594             }
1595              
1596 0         0 return @range_regexp;
1597             }
1598              
1599             #
1600             # Latin-1 open character list for qr and not qr
1601             #
1602             sub _charlist {
1603              
1604 182     358   501 my $modifier = pop @_;
1605 358         600 my @char = @_;
1606              
1607 358 100       732 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1608              
1609             # unescape character
1610 358         773 for (my $i=0; $i <= $#char; $i++) {
1611              
1612             # escape - to ...
1613 358 100 100     1399 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1614 1125 100 100     8247 if ((0 < $i) and ($i < $#char)) {
1615 206         709 $char[$i] = '...';
1616             }
1617             }
1618              
1619             # octal escape sequence
1620             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1621 182         580 $char[$i] = octchr($1);
1622             }
1623              
1624             # hexadecimal escape sequence
1625             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1626 0         0 $char[$i] = hexchr($1);
1627             }
1628              
1629             # \b{...} --> b\{...}
1630             # \B{...} --> B\{...}
1631             # \N{CHARNAME} --> N\{CHARNAME}
1632             # \p{PROPERTY} --> p\{PROPERTY}
1633             # \P{PROPERTY} --> P\{PROPERTY}
1634             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1635 0         0 $char[$i] = $1 . '\\' . $2;
1636             }
1637              
1638             # \p, \P, \X --> p, P, X
1639             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1640 0         0 $char[$i] = $1;
1641             }
1642              
1643             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1644 0         0 $char[$i] = CORE::chr oct $1;
1645             }
1646             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1647 0         0 $char[$i] = CORE::chr hex $1;
1648             }
1649             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1650 22         97 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1651             }
1652             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1653             $char[$i] = {
1654             '\0' => "\0",
1655             '\n' => "\n",
1656             '\r' => "\r",
1657             '\t' => "\t",
1658             '\f' => "\f",
1659             '\b' => "\x08", # \b means backspace in character class
1660             '\a' => "\a",
1661             '\e' => "\e",
1662             '\d' => '[0-9]',
1663              
1664             # Vertical tabs are now whitespace
1665             # \s in a regex now matches a vertical tab in all circumstances.
1666             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1667             # \t \n \v \f \r space
1668             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1669             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1670             '\s' => '\s',
1671              
1672             '\w' => '[0-9A-Z_a-z]',
1673             '\D' => '${Elatin1::eD}',
1674             '\S' => '${Elatin1::eS}',
1675             '\W' => '${Elatin1::eW}',
1676              
1677             '\H' => '${Elatin1::eH}',
1678             '\V' => '${Elatin1::eV}',
1679             '\h' => '[\x09\x20]',
1680             '\v' => '[\x0A\x0B\x0C\x0D]',
1681             '\R' => '${Elatin1::eR}',
1682              
1683 0         0 }->{$1};
1684             }
1685              
1686             # POSIX-style character classes
1687             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1688             $char[$i] = {
1689              
1690             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1691             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1692             '[:^lower:]' => '${Elatin1::not_lower_i}',
1693             '[:^upper:]' => '${Elatin1::not_upper_i}',
1694              
1695 25         515 }->{$1};
1696             }
1697             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1698             $char[$i] = {
1699              
1700             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1701             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1702             '[:ascii:]' => '[\x00-\x7F]',
1703             '[:blank:]' => '[\x09\x20]',
1704             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1705             '[:digit:]' => '[\x30-\x39]',
1706             '[:graph:]' => '[\x21-\x7F]',
1707             '[:lower:]' => '[\x61-\x7A]',
1708             '[:print:]' => '[\x20-\x7F]',
1709             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1710              
1711             # P.174 POSIX-Style Character Classes
1712             # in Chapter 5: Pattern Matching
1713             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1714              
1715             # P.311 11.2.4 Character Classes and other Special Escapes
1716             # in Chapter 11: perlre: Perl regular expressions
1717             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1718              
1719             # P.210 POSIX-Style Character Classes
1720             # in Chapter 5: Pattern Matching
1721             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1722              
1723             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1724              
1725             '[:upper:]' => '[\x41-\x5A]',
1726             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1727             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1728             '[:^alnum:]' => '${Elatin1::not_alnum}',
1729             '[:^alpha:]' => '${Elatin1::not_alpha}',
1730             '[:^ascii:]' => '${Elatin1::not_ascii}',
1731             '[:^blank:]' => '${Elatin1::not_blank}',
1732             '[:^cntrl:]' => '${Elatin1::not_cntrl}',
1733             '[:^digit:]' => '${Elatin1::not_digit}',
1734             '[:^graph:]' => '${Elatin1::not_graph}',
1735             '[:^lower:]' => '${Elatin1::not_lower}',
1736             '[:^print:]' => '${Elatin1::not_print}',
1737             '[:^punct:]' => '${Elatin1::not_punct}',
1738             '[:^space:]' => '${Elatin1::not_space}',
1739             '[:^upper:]' => '${Elatin1::not_upper}',
1740             '[:^word:]' => '${Elatin1::not_word}',
1741             '[:^xdigit:]' => '${Elatin1::not_xdigit}',
1742              
1743 8         54 }->{$1};
1744             }
1745             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1746 70         1190 $char[$i] = $1;
1747             }
1748             }
1749              
1750             # open character list
1751 7         29 my @singleoctet = ();
1752 358         708 my @multipleoctet = ();
1753 358         597 for (my $i=0; $i <= $#char; ) {
1754              
1755             # escaped -
1756 358 100 100     898 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1757 943         3853 $i += 1;
1758 182         256 next;
1759             }
1760              
1761             # make range regexp
1762             elsif ($char[$i] eq '...') {
1763              
1764             # range error
1765 182 50       341 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1766 182         903 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1767             }
1768             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1769 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1770 182         483 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1771             }
1772             }
1773              
1774             # make range regexp per length
1775 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1776 182         556 my @regexp = ();
1777              
1778             # is first and last
1779 182 50 33     303 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1780 182         596 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1781             }
1782              
1783             # is first
1784             elsif ($length == CORE::length($char[$i-1])) {
1785 182         496 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1786             }
1787              
1788             # is inside in first and last
1789             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1790 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1791             }
1792              
1793             # is last
1794             elsif ($length == CORE::length($char[$i+1])) {
1795 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1796             }
1797              
1798             else {
1799 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1800             }
1801              
1802 0 50       0 if ($length == 1) {
1803 182         355 push @singleoctet, @regexp;
1804             }
1805             else {
1806 182         411 push @multipleoctet, @regexp;
1807             }
1808             }
1809              
1810 0         0 $i += 2;
1811             }
1812              
1813             # with /i modifier
1814             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1815 182 100       364 if ($modifier =~ /i/oxms) {
1816 493         712 my $uc = Elatin1::uc($char[$i]);
1817 24         46 my $fc = Elatin1::fc($char[$i]);
1818 24 100       50 if ($uc ne $fc) {
1819 24 50       46 if (CORE::length($fc) == 1) {
1820 12         21 push @singleoctet, $uc, $fc;
1821             }
1822             else {
1823 12         20 push @singleoctet, $uc;
1824 0         0 push @multipleoctet, $fc;
1825             }
1826             }
1827             else {
1828 0         0 push @singleoctet, $char[$i];
1829             }
1830             }
1831             else {
1832 12         24 push @singleoctet, $char[$i];
1833             }
1834 469         680 $i += 1;
1835             }
1836              
1837             # single character of single octet code
1838             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1839 493         784 push @singleoctet, "\t", "\x20";
1840 0         0 $i += 1;
1841             }
1842             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1843 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1844 0         0 $i += 1;
1845             }
1846             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1847 0         0 push @singleoctet, $char[$i];
1848 2         6 $i += 1;
1849             }
1850              
1851             # single character of multiple-octet code
1852             else {
1853 2         5 push @multipleoctet, $char[$i];
1854 84         186 $i += 1;
1855             }
1856             }
1857              
1858             # quote metachar
1859 84         152 for (@singleoctet) {
1860 358 50       669 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1861 689         2981 $_ = '-';
1862             }
1863             elsif (/\A \n \z/oxms) {
1864 0         0 $_ = '\n';
1865             }
1866             elsif (/\A \r \z/oxms) {
1867 8         19 $_ = '\r';
1868             }
1869             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1870 8         31 $_ = sprintf('\x%02X', CORE::ord $1);
1871             }
1872             elsif (/\A [\x00-\xFF] \z/oxms) {
1873 60         196 $_ = quotemeta $_;
1874             }
1875             }
1876              
1877             # return character list
1878 429         648 return \@singleoctet, \@multipleoctet;
1879             }
1880              
1881             #
1882             # Latin-1 octal escape sequence
1883             #
1884             sub octchr {
1885 358     5 0 1186 my($octdigit) = @_;
1886              
1887 5         14 my @binary = ();
1888 5         11 for my $octal (split(//,$octdigit)) {
1889             push @binary, {
1890             '0' => '000',
1891             '1' => '001',
1892             '2' => '010',
1893             '3' => '011',
1894             '4' => '100',
1895             '5' => '101',
1896             '6' => '110',
1897             '7' => '111',
1898 5         30 }->{$octal};
1899             }
1900 50         173 my $binary = join '', @binary;
1901              
1902             my $octchr = {
1903             # 1234567
1904             1 => pack('B*', "0000000$binary"),
1905             2 => pack('B*', "000000$binary"),
1906             3 => pack('B*', "00000$binary"),
1907             4 => pack('B*', "0000$binary"),
1908             5 => pack('B*', "000$binary"),
1909             6 => pack('B*', "00$binary"),
1910             7 => pack('B*', "0$binary"),
1911             0 => pack('B*', "$binary"),
1912              
1913 5         16 }->{CORE::length($binary) % 8};
1914              
1915 5         66 return $octchr;
1916             }
1917              
1918             #
1919             # Latin-1 hexadecimal escape sequence
1920             #
1921             sub hexchr {
1922 5     5 0 20 my($hexdigit) = @_;
1923              
1924             my $hexchr = {
1925             1 => pack('H*', "0$hexdigit"),
1926             0 => pack('H*', "$hexdigit"),
1927              
1928 5         14 }->{CORE::length($_[0]) % 2};
1929              
1930 5         40 return $hexchr;
1931             }
1932              
1933             #
1934             # Latin-1 open character list for qr
1935             #
1936             sub charlist_qr {
1937              
1938 5     314 0 16 my $modifier = pop @_;
1939 314         622 my @char = @_;
1940              
1941 314         859 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1942 314         929 my @singleoctet = @$singleoctet;
1943 314         645 my @multipleoctet = @$multipleoctet;
1944              
1945             # return character list
1946 314 100       469 if (scalar(@singleoctet) >= 1) {
1947              
1948             # with /i modifier
1949 314 100       731 if ($modifier =~ m/i/oxms) {
1950 236         503 my %singleoctet_ignorecase = ();
1951 22         32 for (@singleoctet) {
1952 22   100     36 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1953 46         210 for my $ord (hex($1) .. hex($2)) {
1954 46         130 my $char = CORE::chr($ord);
1955 66         95 my $uc = Elatin1::uc($char);
1956 66         103 my $fc = Elatin1::fc($char);
1957 66 100       95 if ($uc eq $fc) {
1958 66         117 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1959             }
1960             else {
1961 12 50       70 if (CORE::length($fc) == 1) {
1962 54         67 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1963 54         125 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1964             }
1965             else {
1966 54         189 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1967 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1968             }
1969             }
1970             }
1971             }
1972 0 50       0 if ($_ ne '') {
1973 46         90 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1974             }
1975             }
1976 0         0 my $i = 0;
1977 22         32 my @singleoctet_ignorecase = ();
1978 22         28 for my $ord (0 .. 255) {
1979 22 100       30 if (exists $singleoctet_ignorecase{$ord}) {
1980 5632         7558 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         102  
1981             }
1982             else {
1983 96         218 $i++;
1984             }
1985             }
1986 5536         6807 @singleoctet = ();
1987 22         42 for my $range (@singleoctet_ignorecase) {
1988 22 100       67 if (ref $range) {
1989 3648 100       5689 if (scalar(@{$range}) == 1) {
  56 50       53  
1990 56         152 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         42  
1991             }
1992 36         126 elsif (scalar(@{$range}) == 2) {
1993 20         25 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1994             }
1995             else {
1996 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         26  
1997             }
1998             }
1999             }
2000             }
2001              
2002 20         100 my $not_anchor = '';
2003              
2004 236         370 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2005             }
2006 236 100       1316 if (scalar(@multipleoctet) >= 2) {
2007 314         766 return '(?:' . join('|', @multipleoctet) . ')';
2008             }
2009             else {
2010 6         33 return $multipleoctet[0];
2011             }
2012             }
2013              
2014             #
2015             # Latin-1 open character list for not qr
2016             #
2017             sub charlist_not_qr {
2018              
2019 308     44 0 1495 my $modifier = pop @_;
2020 44         84 my @char = @_;
2021              
2022 44         113 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2023 44         134 my @singleoctet = @$singleoctet;
2024 44         92 my @multipleoctet = @$multipleoctet;
2025              
2026             # with /i modifier
2027 44 100       76 if ($modifier =~ m/i/oxms) {
2028 44         103 my %singleoctet_ignorecase = ();
2029 10         12 for (@singleoctet) {
2030 10   66     15 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2031 10         41 for my $ord (hex($1) .. hex($2)) {
2032 10         33 my $char = CORE::chr($ord);
2033 30         47 my $uc = Elatin1::uc($char);
2034 30         41 my $fc = Elatin1::fc($char);
2035 30 50       44 if ($uc eq $fc) {
2036 30         49 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2037             }
2038             else {
2039 0 50       0 if (CORE::length($fc) == 1) {
2040 30         40 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2041 30         64 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2042             }
2043             else {
2044 30         105 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2045 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2046             }
2047             }
2048             }
2049             }
2050 0 50       0 if ($_ ne '') {
2051 10         21 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2052             }
2053             }
2054 0         0 my $i = 0;
2055 10         13 my @singleoctet_ignorecase = ();
2056 10         12 for my $ord (0 .. 255) {
2057 10 100       17 if (exists $singleoctet_ignorecase{$ord}) {
2058 2560         2801 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         56  
2059             }
2060             else {
2061 60         107 $i++;
2062             }
2063             }
2064 2500         2438 @singleoctet = ();
2065 10         12 for my $range (@singleoctet_ignorecase) {
2066 10 100       24 if (ref $range) {
2067 960 50       1523 if (scalar(@{$range}) == 1) {
  20 50       17  
2068 20         31 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2069             }
2070 0         0 elsif (scalar(@{$range}) == 2) {
2071 20         27 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2072             }
2073             else {
2074 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         23  
  20         21  
2075             }
2076             }
2077             }
2078             }
2079              
2080             # return character list
2081 20 50       77 if (scalar(@multipleoctet) >= 1) {
2082 44 0       99 if (scalar(@singleoctet) >= 1) {
2083              
2084             # any character other than multiple-octet and single octet character class
2085 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2086             }
2087             else {
2088              
2089             # any character other than multiple-octet character class
2090 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2091             }
2092             }
2093             else {
2094 0 50       0 if (scalar(@singleoctet) >= 1) {
2095              
2096             # any character other than single octet character class
2097 44         96 return '(?:[^' . join('', @singleoctet) . '])';
2098             }
2099             else {
2100              
2101             # any character
2102 44         252 return "(?:$your_char)";
2103             }
2104             }
2105             }
2106              
2107             #
2108             # open file in read mode
2109             #
2110             sub _open_r {
2111 0     408   0 my(undef,$file) = @_;
2112 204     204   6699 use Fcntl qw(O_RDONLY);
  204         609  
  204         46124  
2113 408         1252 return CORE::sysopen($_[0], $file, &O_RDONLY);
2114             }
2115              
2116             #
2117             # open file in append mode
2118             #
2119             sub _open_a {
2120 408     204   18119 my(undef,$file) = @_;
2121 204     204   1686 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         436  
  204         715313  
2122 204         664 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2123             }
2124              
2125             #
2126             # safe system
2127             #
2128             sub _systemx {
2129              
2130             # P.707 29.2.33. exec
2131             # in Chapter 29: Functions
2132             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2133             #
2134             # Be aware that in older releases of Perl, exec (and system) did not flush
2135             # your output buffer, so you needed to enable command buffering by setting $|
2136             # on one or more filehandles to avoid lost output in the case of exec, or
2137             # misordererd output in the case of system. This situation was largely remedied
2138             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2139              
2140             # P.855 exec
2141             # in Chapter 27: Functions
2142             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2143             #
2144             # In very old release of Perl (before v5.6), 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 with exec or misordered
2147             # output with system.
2148              
2149 204     204   31934 $| = 1;
2150              
2151             # P.565 23.1.2. Cleaning Up Your Environment
2152             # in Chapter 23: Security
2153             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2154              
2155             # P.656 Cleaning Up Your Environment
2156             # in Chapter 20: Security
2157             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2158              
2159             # local $ENV{'PATH'} = '.';
2160 204         677 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2161              
2162             # P.707 29.2.33. exec
2163             # in Chapter 29: Functions
2164             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2165             #
2166             # As we mentioned earlier, exec treats a discrete list of arguments as an
2167             # indication that it should bypass shell processing. However, there is one
2168             # place where you might still get tripped up. The exec call (and system, too)
2169             # will not distinguish between a single scalar argument and an array containing
2170             # only one element.
2171             #
2172             # @args = ("echo surprise"); # just one element in list
2173             # exec @args # still subject to shell escapes
2174             # or die "exec: $!"; # because @args == 1
2175             #
2176             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2177             # first argument as the pathname, which forces the rest of the arguments to be
2178             # interpreted as a list, even if there is only one of them:
2179             #
2180             # exec { $args[0] } @args # safe even with one-argument list
2181             # or die "can't exec @args: $!";
2182              
2183             # P.855 exec
2184             # in Chapter 27: Functions
2185             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2186             #
2187             # As we mentioned earlier, exec treats a discrete list of arguments as a
2188             # directive to bypass shell processing. However, there is one place where
2189             # you might still get tripped up. The exec call (and system, too) cannot
2190             # distinguish between a single scalar argument and an array containing
2191             # only one element.
2192             #
2193             # @args = ("echo surprise"); # just one element in list
2194             # exec @args # still subject to shell escapes
2195             # || die "exec: $!"; # because @args == 1
2196             #
2197             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2198             # argument as the pathname, which forces the rest of the arguments to be
2199             # interpreted as a list, even if there is only one of them:
2200             #
2201             # exec { $args[0] } @args # safe even with one-argument list
2202             # || die "can't exec @args: $!";
2203              
2204 204         1770 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         501  
2205             }
2206              
2207             #
2208             # Latin-1 order to character (with parameter)
2209             #
2210             sub Elatin1::chr(;$) {
2211              
2212 204 0   0 0 21238156 my $c = @_ ? $_[0] : $_;
2213              
2214 0 0       0 if ($c == 0x00) {
2215 0         0 return "\x00";
2216             }
2217             else {
2218 0         0 my @chr = ();
2219 0         0 while ($c > 0) {
2220 0         0 unshift @chr, ($c % 0x100);
2221 0         0 $c = int($c / 0x100);
2222             }
2223 0         0 return pack 'C*', @chr;
2224             }
2225             }
2226              
2227             #
2228             # Latin-1 order to character (without parameter)
2229             #
2230             sub Elatin1::chr_() {
2231              
2232 0     0 0 0 my $c = $_;
2233              
2234 0 0       0 if ($c == 0x00) {
2235 0         0 return "\x00";
2236             }
2237             else {
2238 0         0 my @chr = ();
2239 0         0 while ($c > 0) {
2240 0         0 unshift @chr, ($c % 0x100);
2241 0         0 $c = int($c / 0x100);
2242             }
2243 0         0 return pack 'C*', @chr;
2244             }
2245             }
2246              
2247             #
2248             # Latin-1 path globbing (with parameter)
2249             #
2250             sub Elatin1::glob($) {
2251              
2252 0 0   0 0 0 if (wantarray) {
2253 0         0 my @glob = _DOS_like_glob(@_);
2254 0         0 for my $glob (@glob) {
2255 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2256             }
2257 0         0 return @glob;
2258             }
2259             else {
2260 0         0 my $glob = _DOS_like_glob(@_);
2261 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2262 0         0 return $glob;
2263             }
2264             }
2265              
2266             #
2267             # Latin-1 path globbing (without parameter)
2268             #
2269             sub Elatin1::glob_() {
2270              
2271 0 0   0 0 0 if (wantarray) {
2272 0         0 my @glob = _DOS_like_glob();
2273 0         0 for my $glob (@glob) {
2274 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2275             }
2276 0         0 return @glob;
2277             }
2278             else {
2279 0         0 my $glob = _DOS_like_glob();
2280 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2281 0         0 return $glob;
2282             }
2283             }
2284              
2285             #
2286             # Latin-1 path globbing via File::DosGlob 1.10
2287             #
2288             # Often I confuse "_dosglob" and "_doglob".
2289             # So, I renamed "_dosglob" to "_DOS_like_glob".
2290             #
2291             my %iter;
2292             my %entries;
2293             sub _DOS_like_glob {
2294              
2295             # context (keyed by second cxix argument provided by core)
2296 0     0   0 my($expr,$cxix) = @_;
2297              
2298             # glob without args defaults to $_
2299 0 0       0 $expr = $_ if not defined $expr;
2300              
2301             # represents the current user's home directory
2302             #
2303             # 7.3. Expanding Tildes in Filenames
2304             # in Chapter 7. File Access
2305             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2306             #
2307             # and File::HomeDir, File::HomeDir::Windows module
2308              
2309             # DOS-like system
2310 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2311 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2312             { my_home_MSWin32() }oxmse;
2313             }
2314              
2315             # UNIX-like system
2316 0 0 0     0 else {
  0         0  
2317             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2318             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2319             }
2320 0 0       0  
2321 0 0       0 # assume global context if not provided one
2322             $cxix = '_G_' if not defined $cxix;
2323             $iter{$cxix} = 0 if not exists $iter{$cxix};
2324 0 0       0  
2325 0         0 # if we're just beginning, do it all first
2326             if ($iter{$cxix} == 0) {
2327             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2328             }
2329 0 0       0  
2330 0         0 # chuck it all out, quick or slow
2331 0         0 if (wantarray) {
  0         0  
2332             delete $iter{$cxix};
2333             return @{delete $entries{$cxix}};
2334 0 0       0 }
  0         0  
2335 0         0 else {
  0         0  
2336             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2337             return shift @{$entries{$cxix}};
2338             }
2339 0         0 else {
2340 0         0 # return undef for EOL
2341 0         0 delete $iter{$cxix};
2342             delete $entries{$cxix};
2343             return undef;
2344             }
2345             }
2346             }
2347              
2348             #
2349             # Latin-1 path globbing subroutine
2350             #
2351 0     0   0 sub _do_glob {
2352 0         0  
2353 0         0 my($cond,@expr) = @_;
2354             my @glob = ();
2355             my $fix_drive_relative_paths = 0;
2356 0         0  
2357 0 0       0 OUTER:
2358 0 0       0 for my $expr (@expr) {
2359             next OUTER if not defined $expr;
2360 0         0 next OUTER if $expr eq '';
2361 0         0  
2362 0         0 my @matched = ();
2363 0         0 my @globdir = ();
2364 0         0 my $head = '.';
2365             my $pathsep = '/';
2366             my $tail;
2367 0 0       0  
2368 0         0 # if argument is within quotes strip em and do no globbing
2369 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2370 0 0       0 $expr = $1;
2371 0         0 if ($cond eq 'd') {
2372             if (-d $expr) {
2373             push @glob, $expr;
2374             }
2375 0 0       0 }
2376 0         0 else {
2377             if (-e $expr) {
2378             push @glob, $expr;
2379 0         0 }
2380             }
2381             next OUTER;
2382             }
2383              
2384 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2385 0 0       0 # to h:./*.pm to expand correctly
2386 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2387             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2388             $fix_drive_relative_paths = 1;
2389             }
2390 0 0       0 }
2391 0 0       0  
2392 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2393 0         0 if ($tail eq '') {
2394             push @glob, $expr;
2395 0 0       0 next OUTER;
2396 0 0       0 }
2397 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2398 0         0 if (@globdir = _do_glob('d', $head)) {
2399             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2400             next OUTER;
2401 0 0 0     0 }
2402 0         0 }
2403             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2404 0         0 $head .= $pathsep;
2405             }
2406             $expr = $tail;
2407             }
2408 0 0       0  
2409 0 0       0 # If file component has no wildcards, we can avoid opendir
2410 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2411             if ($head eq '.') {
2412 0 0 0     0 $head = '';
2413 0         0 }
2414             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2415 0         0 $head .= $pathsep;
2416 0 0       0 }
2417 0 0       0 $head .= $expr;
2418 0         0 if ($cond eq 'd') {
2419             if (-d $head) {
2420             push @glob, $head;
2421             }
2422 0 0       0 }
2423 0         0 else {
2424             if (-e $head) {
2425             push @glob, $head;
2426 0         0 }
2427             }
2428 0 0       0 next OUTER;
2429 0         0 }
2430 0         0 opendir(*DIR, $head) or next OUTER;
2431             my @leaf = readdir DIR;
2432 0 0       0 closedir DIR;
2433 0         0  
2434             if ($head eq '.') {
2435 0 0 0     0 $head = '';
2436 0         0 }
2437             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2438             $head .= $pathsep;
2439 0         0 }
2440 0         0  
2441 0         0 my $pattern = '';
2442             while ($expr =~ / \G ($q_char) /oxgc) {
2443             my $char = $1;
2444              
2445             # 6.9. Matching Shell Globs as Regular Expressions
2446             # in Chapter 6. Pattern Matching
2447             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2448 0 0       0 # (and so on)
    0          
    0          
2449 0         0  
2450             if ($char eq '*') {
2451             $pattern .= "(?:$your_char)*",
2452 0         0 }
2453             elsif ($char eq '?') {
2454             $pattern .= "(?:$your_char)?", # DOS style
2455             # $pattern .= "(?:$your_char)", # UNIX style
2456 0         0 }
2457             elsif ((my $fc = Elatin1::fc($char)) ne $char) {
2458             $pattern .= $fc;
2459 0         0 }
2460             else {
2461             $pattern .= quotemeta $char;
2462 0     0   0 }
  0         0  
2463             }
2464             my $matchsub = sub { Elatin1::fc($_[0]) =~ /\A $pattern \z/xms };
2465              
2466             # if ($@) {
2467             # print STDERR "$0: $@\n";
2468             # next OUTER;
2469             # }
2470 0         0  
2471 0 0 0     0 INNER:
2472 0         0 for my $leaf (@leaf) {
2473             if ($leaf eq '.' or $leaf eq '..') {
2474 0 0 0     0 next INNER;
2475 0         0 }
2476             if ($cond eq 'd' and not -d "$head$leaf") {
2477             next INNER;
2478 0 0       0 }
2479 0         0  
2480 0         0 if (&$matchsub($leaf)) {
2481             push @matched, "$head$leaf";
2482             next INNER;
2483             }
2484              
2485             # [DOS compatibility special case]
2486 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2487              
2488             if (Elatin1::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2489             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2490 0 0       0 Elatin1::index($pattern,'\\.') != -1 # pattern has a dot.
2491 0         0 ) {
2492 0         0 if (&$matchsub("$leaf.")) {
2493             push @matched, "$head$leaf";
2494             next INNER;
2495             }
2496 0 0       0 }
2497 0         0 }
2498             if (@matched) {
2499             push @glob, @matched;
2500 0 0       0 }
2501 0         0 }
2502 0         0 if ($fix_drive_relative_paths) {
2503             for my $glob (@glob) {
2504             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2505 0         0 }
2506             }
2507             return @glob;
2508             }
2509              
2510             #
2511             # Latin-1 parse line
2512             #
2513 0     0   0 sub _parse_line {
2514              
2515 0         0 my($line) = @_;
2516 0         0  
2517 0         0 $line .= ' ';
2518             my @piece = ();
2519             while ($line =~ /
2520             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2521             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2522 0 0       0 /oxmsg
2523             ) {
2524 0         0 push @piece, defined($1) ? $1 : $2;
2525             }
2526             return @piece;
2527             }
2528              
2529             #
2530             # Latin-1 parse path
2531             #
2532 0     0   0 sub _parse_path {
2533              
2534 0         0 my($path,$pathsep) = @_;
2535 0         0  
2536 0         0 $path .= '/';
2537             my @subpath = ();
2538             while ($path =~ /
2539             ((?: [^\/\\] )+?) [\/\\]
2540 0         0 /oxmsg
2541             ) {
2542             push @subpath, $1;
2543 0         0 }
2544 0         0  
2545 0         0 my $tail = pop @subpath;
2546             my $head = join $pathsep, @subpath;
2547             return $head, $tail;
2548             }
2549              
2550             #
2551             # via File::HomeDir::Windows 1.00
2552             #
2553             sub my_home_MSWin32 {
2554              
2555             # A lot of unix people and unix-derived tools rely on
2556 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2557 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2558             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2559             return $ENV{'HOME'};
2560             }
2561              
2562 0         0 # Do we have a user profile?
2563             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2564             return $ENV{'USERPROFILE'};
2565             }
2566              
2567 0         0 # Some Windows use something like $ENV{'HOME'}
2568             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2569             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2570 0         0 }
2571              
2572             return undef;
2573             }
2574              
2575             #
2576             # via File::HomeDir::Unix 1.00
2577 0     0 0 0 #
2578             sub my_home {
2579 0 0 0     0 my $home;
    0 0        
2580 0         0  
2581             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2582             $home = $ENV{'HOME'};
2583             }
2584              
2585             # This is from the original code, but I'm guessing
2586 0         0 # it means "login directory" and exists on some Unixes.
2587             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2588             $home = $ENV{'LOGDIR'};
2589             }
2590              
2591             ### More-desperate methods
2592              
2593 0         0 # Light desperation on any (Unixish) platform
2594             else {
2595             $home = CORE::eval q{ (getpwuid($<))[7] };
2596             }
2597              
2598 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2599 0         0 # For example, "nobody"-like users might use /nonexistant
2600             if (defined $home and ! -d($home)) {
2601 0         0 $home = undef;
2602             }
2603             return $home;
2604             }
2605              
2606             #
2607             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2608 0     0 0 0 #
2609             sub Elatin1::PREMATCH {
2610             return $`;
2611             }
2612              
2613             #
2614             # ${^MATCH}, $MATCH, $& the string that matched
2615 0     0 0 0 #
2616             sub Elatin1::MATCH {
2617             return $&;
2618             }
2619              
2620             #
2621             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2622 0     0 0 0 #
2623             sub Elatin1::POSTMATCH {
2624             return $';
2625             }
2626              
2627             #
2628             # Latin-1 character to order (with parameter)
2629             #
2630 0 0   0 1 0 sub Latin1::ord(;$) {
2631              
2632 0 0       0 local $_ = shift if @_;
2633 0         0  
2634 0         0 if (/\A ($q_char) /oxms) {
2635 0         0 my @ord = unpack 'C*', $1;
2636 0         0 my $ord = 0;
2637             while (my $o = shift @ord) {
2638 0         0 $ord = $ord * 0x100 + $o;
2639             }
2640             return $ord;
2641 0         0 }
2642             else {
2643             return CORE::ord $_;
2644             }
2645             }
2646              
2647             #
2648             # Latin-1 character to order (without parameter)
2649             #
2650 0 0   0 0 0 sub Latin1::ord_() {
2651 0         0  
2652 0         0 if (/\A ($q_char) /oxms) {
2653 0         0 my @ord = unpack 'C*', $1;
2654 0         0 my $ord = 0;
2655             while (my $o = shift @ord) {
2656 0         0 $ord = $ord * 0x100 + $o;
2657             }
2658             return $ord;
2659 0         0 }
2660             else {
2661             return CORE::ord $_;
2662             }
2663             }
2664              
2665             #
2666             # Latin-1 reverse
2667             #
2668 0 0   0 0 0 sub Latin1::reverse(@) {
2669 0         0  
2670             if (wantarray) {
2671             return CORE::reverse @_;
2672             }
2673             else {
2674              
2675             # One of us once cornered Larry in an elevator and asked him what
2676             # problem he was solving with this, but he looked as far off into
2677             # the distance as he could in an elevator and said, "It seemed like
2678 0         0 # a good idea at the time."
2679              
2680             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2681             }
2682             }
2683              
2684             #
2685             # Latin-1 getc (with parameter, without parameter)
2686             #
2687 0     0 0 0 sub Latin1::getc(;*@) {
2688 0 0       0  
2689 0 0 0     0 my($package) = caller;
2690             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2691 0         0 croak 'Too many arguments for Latin1::getc' if @_ and not wantarray;
  0         0  
2692 0         0  
2693 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2694 0         0 my $getc = '';
2695 0 0       0 for my $length ($length[0] .. $length[-1]) {
2696 0 0       0 $getc .= CORE::getc($fh);
2697 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2698             if ($getc =~ /\A ${Elatin1::dot_s} \z/oxms) {
2699             return wantarray ? ($getc,@_) : $getc;
2700             }
2701 0 0       0 }
2702             }
2703             return wantarray ? ($getc,@_) : $getc;
2704             }
2705              
2706             #
2707             # Latin-1 length by character
2708             #
2709 0 0   0 1 0 sub Latin1::length(;$) {
2710              
2711 0         0 local $_ = shift if @_;
2712 0         0  
2713             local @_ = /\G ($q_char) /oxmsg;
2714             return scalar @_;
2715             }
2716              
2717             #
2718             # Latin-1 substr by character
2719             #
2720             BEGIN {
2721              
2722             # P.232 The lvalue Attribute
2723             # in Chapter 6: Subroutines
2724             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2725              
2726             # P.336 The lvalue Attribute
2727             # in Chapter 7: Subroutines
2728             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2729              
2730             # P.144 8.4 Lvalue subroutines
2731             # in Chapter 8: perlsub: Perl subroutines
2732 204 50 0 204 1 182350 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2733              
2734             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2735             # vv----------------------*******
2736             sub Latin1::substr($$;$$) %s {
2737              
2738             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2739              
2740             # If the substring is beyond either end of the string, substr() returns the undefined
2741             # value and produces a warning. When used as an lvalue, specifying a substring that
2742             # is entirely outside the string raises an exception.
2743             # http://perldoc.perl.org/functions/substr.html
2744              
2745             # A return with no argument returns the scalar value undef in scalar context,
2746             # an empty list () in list context, and (naturally) nothing at all in void
2747             # context.
2748              
2749             my $offset = $_[1];
2750             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2751             return;
2752             }
2753              
2754             # substr($string,$offset,$length,$replacement)
2755             if (@_ == 4) {
2756             my(undef,undef,$length,$replacement) = @_;
2757             my $substr = join '', splice(@char, $offset, $length, $replacement);
2758             $_[0] = join '', @char;
2759              
2760             # return $substr; this doesn't work, don't say "return"
2761             $substr;
2762             }
2763              
2764             # substr($string,$offset,$length)
2765             elsif (@_ == 3) {
2766             my(undef,undef,$length) = @_;
2767             my $octet_offset = 0;
2768             my $octet_length = 0;
2769             if ($offset == 0) {
2770             $octet_offset = 0;
2771             }
2772             elsif ($offset > 0) {
2773             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2774             }
2775             else {
2776             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2777             }
2778             if ($length == 0) {
2779             $octet_length = 0;
2780             }
2781             elsif ($length > 0) {
2782             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2783             }
2784             else {
2785             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2786             }
2787             CORE::substr($_[0], $octet_offset, $octet_length);
2788             }
2789              
2790             # substr($string,$offset)
2791             else {
2792             my $octet_offset = 0;
2793             if ($offset == 0) {
2794             $octet_offset = 0;
2795             }
2796             elsif ($offset > 0) {
2797             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2798             }
2799             else {
2800             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2801             }
2802             CORE::substr($_[0], $octet_offset);
2803             }
2804             }
2805             END
2806             }
2807              
2808             #
2809             # Latin-1 index by character
2810             #
2811 0     0 1 0 sub Latin1::index($$;$) {
2812 0 0       0  
2813 0         0 my $index;
2814             if (@_ == 3) {
2815             $index = Elatin1::index($_[0], $_[1], CORE::length(Latin1::substr($_[0], 0, $_[2])));
2816 0         0 }
2817             else {
2818             $index = Elatin1::index($_[0], $_[1]);
2819 0 0       0 }
2820 0         0  
2821             if ($index == -1) {
2822             return -1;
2823 0         0 }
2824             else {
2825             return Latin1::length(CORE::substr $_[0], 0, $index);
2826             }
2827             }
2828              
2829             #
2830             # Latin-1 rindex by character
2831             #
2832 0     0 1 0 sub Latin1::rindex($$;$) {
2833 0 0       0  
2834 0         0 my $rindex;
2835             if (@_ == 3) {
2836             $rindex = Elatin1::rindex($_[0], $_[1], CORE::length(Latin1::substr($_[0], 0, $_[2])));
2837 0         0 }
2838             else {
2839             $rindex = Elatin1::rindex($_[0], $_[1]);
2840 0 0       0 }
2841 0         0  
2842             if ($rindex == -1) {
2843             return -1;
2844 0         0 }
2845             else {
2846             return Latin1::length(CORE::substr $_[0], 0, $rindex);
2847             }
2848             }
2849              
2850 204     204   1801 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         504  
  204         24542  
2851             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2852             use vars qw($slash); $slash = 'm//';
2853              
2854             # ord() to ord() or Latin1::ord()
2855             my $function_ord = 'ord';
2856              
2857             # ord to ord or Latin1::ord_
2858             my $function_ord_ = 'ord';
2859              
2860             # reverse to reverse or Latin1::reverse
2861             my $function_reverse = 'reverse';
2862              
2863             # getc to getc or Latin1::getc
2864             my $function_getc = 'getc';
2865              
2866             # P.1023 Appendix W.9 Multibyte Anchoring
2867             # of ISBN 1-56592-224-7 CJKV Information Processing
2868              
2869 204     204   1636 my $anchor = '';
  204     0   456  
  204         10179942  
2870              
2871             use vars qw($nest);
2872              
2873             # regexp of nested parens in qqXX
2874              
2875             # P.340 Matching Nested Constructs with Embedded Code
2876             # in Chapter 7: Perl
2877             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2878              
2879             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2880             [^\\()] |
2881             \( (?{$nest++}) |
2882             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2883             \\ [^c] |
2884             \\c[\x40-\x5F] |
2885             [\x00-\xFF]
2886             }xms;
2887              
2888             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2889             [^\\{}] |
2890             \{ (?{$nest++}) |
2891             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2892             \\ [^c] |
2893             \\c[\x40-\x5F] |
2894             [\x00-\xFF]
2895             }xms;
2896              
2897             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2898             [^\\\[\]] |
2899             \[ (?{$nest++}) |
2900             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2901             \\ [^c] |
2902             \\c[\x40-\x5F] |
2903             [\x00-\xFF]
2904             }xms;
2905              
2906             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2907             [^\\<>] |
2908             \< (?{$nest++}) |
2909             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2910             \\ [^c] |
2911             \\c[\x40-\x5F] |
2912             [\x00-\xFF]
2913             }xms;
2914              
2915             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2916             (?: ::)? (?:
2917             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2918             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2919             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2920             ))
2921             }xms;
2922              
2923             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2924             (?: ::)? (?:
2925             (?>[0-9]+) |
2926             [^a-zA-Z_0-9\[\]] |
2927             ^[A-Z] |
2928             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2929             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2930             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2931             ))
2932             }xms;
2933              
2934             my $qq_substr = qr{(?> Char::substr | Latin1::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2935             }xms;
2936              
2937             # regexp of nested parens in qXX
2938             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2939             [^()] |
2940             \( (?{$nest++}) |
2941             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2942             [\x00-\xFF]
2943             }xms;
2944              
2945             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2946             [^\{\}] |
2947             \{ (?{$nest++}) |
2948             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2949             [\x00-\xFF]
2950             }xms;
2951              
2952             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2953             [^\[\]] |
2954             \[ (?{$nest++}) |
2955             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2956             [\x00-\xFF]
2957             }xms;
2958              
2959             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2960             [^<>] |
2961             \< (?{$nest++}) |
2962             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2963             [\x00-\xFF]
2964             }xms;
2965              
2966             my $matched = '';
2967             my $s_matched = '';
2968              
2969             my $tr_variable = ''; # variable of tr///
2970             my $sub_variable = ''; # variable of s///
2971             my $bind_operator = ''; # =~ or !~
2972              
2973             my @heredoc = (); # here document
2974             my @heredoc_delimiter = ();
2975             my $here_script = ''; # here script
2976              
2977             #
2978             # escape Latin-1 script
2979 0 50   204 0 0 #
2980             sub Latin1::escape(;$) {
2981             local($_) = $_[0] if @_;
2982              
2983             # P.359 The Study Function
2984             # in Chapter 7: Perl
2985 204         627 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2986              
2987             study $_; # Yes, I studied study yesterday.
2988              
2989             # while all script
2990              
2991             # 6.14. Matching from Where the Last Pattern Left Off
2992             # in Chapter 6. Pattern Matching
2993             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2994             # (and so on)
2995              
2996             # one member of Tag-team
2997             #
2998             # P.128 Start of match (or end of previous match): \G
2999             # P.130 Advanced Use of \G with Perl
3000             # in Chapter 3: Overview of Regular Expression Features and Flavors
3001             # P.255 Use leading anchors
3002             # P.256 Expose ^ and \G at the front expressions
3003             # in Chapter 6: Crafting an Efficient Expression
3004             # P.315 "Tag-team" matching with /gc
3005             # in Chapter 7: Perl
3006 204         478 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3007 204         16472  
3008 204         805 my $e_script = '';
3009             while (not /\G \z/oxgc) { # member
3010             $e_script .= Latin1::escape_token();
3011 74677         117180 }
3012              
3013             return $e_script;
3014             }
3015              
3016             #
3017             # escape Latin-1 token of script
3018             #
3019             sub Latin1::escape_token {
3020              
3021 204     74677 0 2610 # \n output here document
3022              
3023             my $ignore_modules = join('|', qw(
3024             utf8
3025             bytes
3026             charnames
3027             I18N::Japanese
3028             I18N::Collate
3029             I18N::JExt
3030             File::DosGlob
3031             Wild
3032             Wildcard
3033             Japanese
3034             ));
3035              
3036             # another member of Tag-team
3037             #
3038             # P.315 "Tag-team" matching with /gc
3039             # in Chapter 7: Perl
3040 74677 100 100     88444 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    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          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3041 74677         3170764  
3042 12502 100       16116 if (/\G ( \n ) /oxgc) { # another member (and so on)
3043 12502         21988 my $heredoc = '';
3044             if (scalar(@heredoc_delimiter) >= 1) {
3045 174         291 $slash = 'm//';
3046 174         360  
3047             $heredoc = join '', @heredoc;
3048             @heredoc = ();
3049 174         293  
3050 174         308 # skip here document
3051             for my $heredoc_delimiter (@heredoc_delimiter) {
3052 174         1328 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3053             }
3054 174         325 @heredoc_delimiter = ();
3055              
3056 174         332 $here_script = '';
3057             }
3058             return "\n" . $heredoc;
3059             }
3060 12502         43614  
3061             # ignore space, comment
3062             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3063              
3064             # if (, elsif (, unless (, while (, until (, given (, and when (
3065              
3066             # given, when
3067              
3068             # P.225 The given Statement
3069             # in Chapter 15: Smart Matching and given-when
3070             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3071              
3072             # P.133 The given Statement
3073             # in Chapter 4: Statements and Declarations
3074             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3075 17874         64436  
3076 1401         2364 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3077             $slash = 'm//';
3078             return $1;
3079             }
3080              
3081             # scalar variable ($scalar = ...) =~ tr///;
3082             # scalar variable ($scalar = ...) =~ s///;
3083              
3084             # state
3085              
3086             # P.68 Persistent, Private Variables
3087             # in Chapter 4: Subroutines
3088             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3089              
3090             # P.160 Persistent Lexically Scoped Variables: state
3091             # in Chapter 4: Statements and Declarations
3092             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3093              
3094             # (and so on)
3095 1401         4237  
3096             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3097 86 50       191 my $e_string = e_string($1);
    50          
3098 86         2178  
3099 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3100 0         0 $tr_variable = $e_string . e_string($1);
3101 0         0 $bind_operator = $2;
3102             $slash = 'm//';
3103             return '';
3104 0         0 }
3105 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3106 0         0 $sub_variable = $e_string . e_string($1);
3107 0         0 $bind_operator = $2;
3108             $slash = 'm//';
3109             return '';
3110 0         0 }
3111 86         152 else {
3112             $slash = 'div';
3113             return $e_string;
3114             }
3115             }
3116              
3117 86         691 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
3118 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3119             $slash = 'div';
3120             return q{Elatin1::PREMATCH()};
3121             }
3122              
3123 4         14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
3124 28         55 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3125             $slash = 'div';
3126             return q{Elatin1::MATCH()};
3127             }
3128              
3129 28         88 # $', ${'} --> $', ${'}
3130 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3131             $slash = 'div';
3132             return $1;
3133             }
3134              
3135 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
3136 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3137             $slash = 'div';
3138             return q{Elatin1::POSTMATCH()};
3139             }
3140              
3141             # scalar variable $scalar =~ tr///;
3142             # scalar variable $scalar =~ s///;
3143             # substr() =~ tr///;
3144 3         11 # substr() =~ s///;
3145             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3146 1671 100       3895 my $scalar = e_string($1);
    100          
3147 1671         6470  
3148 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3149 1         2 $tr_variable = $scalar;
3150 1         2 $bind_operator = $1;
3151             $slash = 'm//';
3152             return '';
3153 1         3 }
3154 61         120 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3155 61         113 $sub_variable = $scalar;
3156 61         94 $bind_operator = $1;
3157             $slash = 'm//';
3158             return '';
3159 61         169 }
3160 1609         2608 else {
3161             $slash = 'div';
3162             return $scalar;
3163             }
3164             }
3165              
3166 1609         20426 # end of statement
3167             elsif (/\G ( [,;] ) /oxgc) {
3168             $slash = 'm//';
3169 4978         7569  
3170             # clear tr/// variable
3171             $tr_variable = '';
3172 4978         6584  
3173             # clear s/// variable
3174 4978         5895 $sub_variable = '';
3175              
3176 4978         5962 $bind_operator = '';
3177              
3178             return $1;
3179             }
3180              
3181 4978         17869 # bareword
3182             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3183             return $1;
3184             }
3185              
3186 0         0 # $0 --> $0
3187 2         4 elsif (/\G ( \$ 0 ) /oxmsgc) {
3188             $slash = 'div';
3189             return $1;
3190 2         7 }
3191 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3192             $slash = 'div';
3193             return $1;
3194             }
3195              
3196 0         0 # $$ --> $$
3197 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3198             $slash = 'div';
3199             return $1;
3200             }
3201              
3202             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3203 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3204 4         9 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3205             $slash = 'div';
3206             return e_capture($1);
3207 4         8 }
3208 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3209             $slash = 'div';
3210             return e_capture($1);
3211             }
3212              
3213 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3214 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3215             $slash = 'div';
3216             return e_capture($1.'->'.$2);
3217             }
3218              
3219 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3220 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3221             $slash = 'div';
3222             return e_capture($1.'->'.$2);
3223             }
3224              
3225 0         0 # $$foo
3226 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3227             $slash = 'div';
3228             return e_capture($1);
3229             }
3230              
3231 0         0 # ${ foo }
3232 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3233             $slash = 'div';
3234             return '${' . $1 . '}';
3235             }
3236              
3237 0         0 # ${ ... }
3238 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3239             $slash = 'div';
3240             return e_capture($1);
3241             }
3242              
3243             # variable or function
3244 0         0 # $ @ % & * $ #
3245 42         65 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) {
3246             $slash = 'div';
3247             return $1;
3248             }
3249             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3250 42         137 # $ @ # \ ' " / ? ( ) [ ] < >
3251 62         195 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3252             $slash = 'div';
3253             return $1;
3254             }
3255              
3256 62         257 # while ()
3257             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3258             return $1;
3259             }
3260              
3261             # while () --- glob
3262              
3263             # avoid "Error: Runtime exception" of perl version 5.005_03
3264 0         0  
3265             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3266             return 'while ($_ = Elatin1::glob("' . $1 . '"))';
3267             }
3268              
3269 0         0 # while (glob)
3270             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3271             return 'while ($_ = Elatin1::glob_)';
3272             }
3273              
3274 0         0 # while (glob(WILDCARD))
3275             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3276             return 'while ($_ = Elatin1::glob';
3277             }
3278 0         0  
  248         508  
3279             # doit if, doit unless, doit while, doit until, doit for, doit when
3280             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3281 248         1003  
  19         37  
3282 19         150 # subroutines of package Elatin1
  0         0  
3283 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         18  
3284 13         32 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3285 0         0 elsif (/\G \b Latin1::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         228  
3286 114         317 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3287 2         6 elsif (/\G \b Latin1::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin1::escape'; }
  0         0  
3288 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         6  
3289 2         313 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::chop'; }
  0         0  
3290 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3291 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3292 0         0 elsif (/\G \b Latin1::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin1::index'; }
  2         5  
3293 2         7 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::index'; }
  0         0  
3294 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3295 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3296 0         0 elsif (/\G \b Latin1::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin1::rindex'; }
  1         4  
3297 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::rindex'; }
  0         0  
3298 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::lc'; }
  1         3  
3299 1         4 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::lcfirst'; }
  0         0  
3300 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::uc'; }
  6         8  
3301             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::ucfirst'; }
3302             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::fc'; }
3303 6         18  
  0         0  
3304 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3305 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3306 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3307 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3308 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3309 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3310             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3311 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  
3312 0         0  
  0         0  
3313 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3314 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3315 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3316 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3317 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3318             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3319             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3320 0         0  
  0         0  
3321 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3322 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3323 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3324             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3325 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         6  
3326 2         5  
  2         7  
3327 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         52  
3328 36         101 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3329 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::chr'; }
  8         14  
3330 8         26 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3331 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3332 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin1::glob'; }
  0         0  
3333 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::lc_'; }
  0         0  
3334 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::lcfirst_'; }
  0         0  
3335 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::uc_'; }
  0         0  
3336 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::ucfirst_'; }
  0         0  
3337             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::fc_'; }
3338 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3339 0         0  
  0         0  
3340 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3341 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3342 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::chr_'; }
  0         0  
3343 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3344 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3345 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin1::glob_'; }
  8         21  
3346             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3347             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3348 8         33 # split
3349             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3350 87         186 $slash = 'm//';
3351 87         136  
3352 87         315 my $e = '';
3353             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3354             $e .= $1;
3355             }
3356 85 100       381  
  87 100       6505  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3357             # end of split
3358             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin1::split' . $e; }
3359 2         11  
3360             # split scalar value
3361             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin1::split' . $e . e_string($1); }
3362 1         6  
3363 0         0 # split literal space
3364 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin1::split' . $e . qq {qq$1 $2}; }
3365 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3366 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3367 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3368 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3369 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin1::split' . $e . qq{$1qq$2 $3}; }
3370 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin1::split' . $e . qq {q$1 $2}; }
3371 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3372 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3373 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3374 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3375 10         47 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin1::split' . $e . qq {$1q$2 $3}; }
3376             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin1::split' . $e . qq {' '}; }
3377             elsif (/\G " [ ] " /oxgc) { return 'Elatin1::split' . $e . qq {" "}; }
3378              
3379 0 0       0 # split qq//
  0         0  
3380             elsif (/\G \b (qq) \b /oxgc) {
3381 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3382 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3383 0         0 while (not /\G \z/oxgc) {
3384 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3385 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3386 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3387 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3388 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3389             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3390 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3391             }
3392             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3393             }
3394             }
3395              
3396 0 50       0 # split qr//
  12         411  
3397             elsif (/\G \b (qr) \b /oxgc) {
3398 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3399 12 50       61 else {
  12 50       3404  
    50          
    50          
    50          
    50          
    50          
    50          
3400 0         0 while (not /\G \z/oxgc) {
3401 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3402 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3403 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3404 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3405 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3406 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3407             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3408 12         119 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3409             }
3410             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3411             }
3412             }
3413              
3414 0 0       0 # split q//
  0         0  
3415             elsif (/\G \b (q) \b /oxgc) {
3416 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3417 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3418 0         0 while (not /\G \z/oxgc) {
3419 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3420 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3421 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3422 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3423 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3424             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3425 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3426             }
3427             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3428             }
3429             }
3430              
3431 0 50       0 # split m//
  18         750  
3432             elsif (/\G \b (m) \b /oxgc) {
3433 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3434 18 50       84 else {
  18 50       3975  
    50          
    50          
    50          
    50          
    50          
    50          
3435 0         0 while (not /\G \z/oxgc) {
3436 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3437 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3438 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3439 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3440 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3441 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3442             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3443 18         132 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3444             }
3445             die __FILE__, ": Search pattern not terminated\n";
3446             }
3447             }
3448              
3449 0         0 # split ''
3450 0         0 elsif (/\G (\') /oxgc) {
3451 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3452 0         0 while (not /\G \z/oxgc) {
3453 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3454 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3455             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3456 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3457             }
3458             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3459             }
3460              
3461 0         0 # split ""
3462 0         0 elsif (/\G (\") /oxgc) {
3463 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3464 0         0 while (not /\G \z/oxgc) {
3465 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3466 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3467             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3468 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3469             }
3470             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3471             }
3472              
3473 0         0 # split //
3474 44         120 elsif (/\G (\/) /oxgc) {
3475 44 50       181 my $regexp = '';
  381 50       1582  
    100          
    50          
3476 0         0 while (not /\G \z/oxgc) {
3477 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3478 44         174 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3479             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3480 337         685 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3481             }
3482             die __FILE__, ": Search pattern not terminated\n";
3483             }
3484             }
3485              
3486             # tr/// or y///
3487              
3488             # about [cdsrbB]* (/B modifier)
3489             #
3490             # P.559 appendix C
3491             # of ISBN 4-89052-384-7 Programming perl
3492             # (Japanese title is: Perl puroguramingu)
3493 0         0  
3494             elsif (/\G \b ( tr | y ) \b /oxgc) {
3495             my $ope = $1;
3496 3 50       9  
3497 3         52 # $1 $2 $3 $4 $5 $6
3498 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3499             my @tr = ($tr_variable,$2);
3500             return e_tr(@tr,'',$4,$6);
3501 0         0 }
3502 3         6 else {
3503 3 50       22 my $e = '';
  3 50       257  
    50          
    50          
    50          
    50          
3504             while (not /\G \z/oxgc) {
3505 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3506 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3507 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3508 0         0 while (not /\G \z/oxgc) {
3509 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3510 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3511 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3512 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3513             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3514 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3515             }
3516             die __FILE__, ": Transliteration replacement not terminated\n";
3517 0         0 }
3518 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3519 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3520 0         0 while (not /\G \z/oxgc) {
3521 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3522 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3523 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3524 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3525             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3526 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3527             }
3528             die __FILE__, ": Transliteration replacement not terminated\n";
3529 0         0 }
3530 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3531 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3532 0         0 while (not /\G \z/oxgc) {
3533 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3534 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3535 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3536 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3537             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3538 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3539             }
3540             die __FILE__, ": Transliteration replacement not terminated\n";
3541 0         0 }
3542 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3543 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3544 0         0 while (not /\G \z/oxgc) {
3545 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3546 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3547 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3548 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3549             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3550 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3551             }
3552             die __FILE__, ": Transliteration replacement not terminated\n";
3553             }
3554 0         0 # $1 $2 $3 $4 $5 $6
3555 3         12 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3556             my @tr = ($tr_variable,$2);
3557             return e_tr(@tr,'',$4,$6);
3558 3         9 }
3559             }
3560             die __FILE__, ": Transliteration pattern not terminated\n";
3561             }
3562             }
3563              
3564 0         0 # qq//
3565             elsif (/\G \b (qq) \b /oxgc) {
3566             my $ope = $1;
3567 2180 50       5999  
3568 2180         4198 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3569 0         0 if (/\G (\#) /oxgc) { # qq# #
3570 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3571 0         0 while (not /\G \z/oxgc) {
3572 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3573 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3574             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3575 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3576             }
3577             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3578             }
3579 0         0  
3580 2180         4031 else {
3581 2180 50       5181 my $e = '';
  2180 50       9212  
    100          
    50          
    50          
    0          
3582             while (not /\G \z/oxgc) {
3583             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3584              
3585 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3586 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3587 0         0 my $qq_string = '';
3588 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3589 0         0 while (not /\G \z/oxgc) {
3590 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3591             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3592 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3593 0         0 elsif (/\G (\)) /oxgc) {
3594             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3595 0         0 else { $qq_string .= $1; }
3596             }
3597 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3598             }
3599             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3600             }
3601              
3602 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3603 2150         3113 elsif (/\G (\{) /oxgc) { # qq { }
3604 2150         16422 my $qq_string = '';
3605 2150 100       4830 local $nest = 1;
  84006 50       284797  
    100          
    100          
    50          
3606 722         1440 while (not /\G \z/oxgc) {
3607 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1652  
3608             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3609 1153 100       2213 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5575  
3610 2150         4454 elsif (/\G (\}) /oxgc) {
3611             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3612 1153         2515 else { $qq_string .= $1; }
3613             }
3614 78828         166882 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3615             }
3616             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3617             }
3618              
3619 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3620 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3621 0         0 my $qq_string = '';
3622 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3623 0         0 while (not /\G \z/oxgc) {
3624 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3625             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3626 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3627 0         0 elsif (/\G (\]) /oxgc) {
3628             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3629 0         0 else { $qq_string .= $1; }
3630             }
3631 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3632             }
3633             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3634             }
3635              
3636 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3637 30         52 elsif (/\G (\<) /oxgc) { # qq < >
3638 30         50 my $qq_string = '';
3639 30 100       99 local $nest = 1;
  1166 50       3908  
    50          
    100          
    50          
3640 22         51 while (not /\G \z/oxgc) {
3641 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3642             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3643 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         68  
3644 30         69 elsif (/\G (\>) /oxgc) {
3645             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3646 0         0 else { $qq_string .= $1; }
3647             }
3648 1114         2053 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3649             }
3650             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3651             }
3652              
3653 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3654 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3655 0         0 my $delimiter = $1;
3656 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3657 0         0 while (not /\G \z/oxgc) {
3658 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3659 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3660             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3661 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3662             }
3663             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3664 0         0 }
3665             }
3666             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3667             }
3668             }
3669              
3670 0         0 # qr//
3671 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3672 0         0 my $ope = $1;
3673             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3674             return e_qr($ope,$1,$3,$2,$4);
3675 0         0 }
3676 0         0 else {
3677 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3678 0         0 while (not /\G \z/oxgc) {
3679 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3680 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3681 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3682 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3683 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3684 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3685             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3686 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3687             }
3688             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3689             }
3690             }
3691              
3692 0         0 # qw//
3693 16 50       50 elsif (/\G \b (qw) \b /oxgc) {
3694 16         107 my $ope = $1;
3695             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3696             return e_qw($ope,$1,$3,$2);
3697 0         0 }
3698 16         37 else {
3699 16 50       59 my $e = '';
  16 50       119  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3700             while (not /\G \z/oxgc) {
3701 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3702 16         54  
3703             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3704 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3705 0         0  
3706             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3707 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3708 0         0  
3709             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3710 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3711 0         0  
3712             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3713 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3714 0         0  
3715             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3716 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3717             }
3718             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3719             }
3720             }
3721              
3722 0         0 # qx//
3723 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3724 0         0 my $ope = $1;
3725             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3726             return e_qq($ope,$1,$3,$2);
3727 0         0 }
3728 0         0 else {
3729 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3730 0         0 while (not /\G \z/oxgc) {
3731 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3732 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3733 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3734 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3735 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3736             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3737 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3738             }
3739             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3740             }
3741             }
3742              
3743 0         0 # q//
3744             elsif (/\G \b (q) \b /oxgc) {
3745             my $ope = $1;
3746              
3747             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3748              
3749             # avoid "Error: Runtime exception" of perl version 5.005_03
3750 410 50       1130 # (and so on)
3751 410         997  
3752 0         0 if (/\G (\#) /oxgc) { # q# #
3753 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3754 0         0 while (not /\G \z/oxgc) {
3755 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3756 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3757             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3758 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3759             }
3760             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3761             }
3762 0         0  
3763 410         733 else {
3764 410 50       1191 my $e = '';
  410 50       2062  
    100          
    50          
    100          
    50          
3765             while (not /\G \z/oxgc) {
3766             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3767              
3768 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3769 0         0 elsif (/\G (\() /oxgc) { # q ( )
3770 0         0 my $q_string = '';
3771 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3772 0         0 while (not /\G \z/oxgc) {
3773 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3774 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3775             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3776 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3777 0         0 elsif (/\G (\)) /oxgc) {
3778             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3779 0         0 else { $q_string .= $1; }
3780             }
3781 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3782             }
3783             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3784             }
3785              
3786 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3787 404         725 elsif (/\G (\{) /oxgc) { # q { }
3788 404         653 my $q_string = '';
3789 404 50       1600 local $nest = 1;
  6770 50       29569  
    50          
    100          
    100          
    50          
3790 0         0 while (not /\G \z/oxgc) {
3791 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3792 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         174  
3793             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3794 107 100       216 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1250  
3795 404         1820 elsif (/\G (\}) /oxgc) {
3796             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3797 107         245 else { $q_string .= $1; }
3798             }
3799 6152         11806 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3800             }
3801             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3802             }
3803              
3804 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3805 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3806 0         0 my $q_string = '';
3807 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3808 0         0 while (not /\G \z/oxgc) {
3809 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3810 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3811             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3812 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3813 0         0 elsif (/\G (\]) /oxgc) {
3814             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3815 0         0 else { $q_string .= $1; }
3816             }
3817 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3818             }
3819             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3820             }
3821              
3822 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3823 5         11 elsif (/\G (\<) /oxgc) { # q < >
3824 5         9 my $q_string = '';
3825 5 50       17 local $nest = 1;
  88 50       352  
    50          
    50          
    100          
    50          
3826 0         0 while (not /\G \z/oxgc) {
3827 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3828 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3829             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3830 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         13  
3831 5         13 elsif (/\G (\>) /oxgc) {
3832             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3833 0         0 else { $q_string .= $1; }
3834             }
3835 83         161 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3836             }
3837             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3838             }
3839              
3840 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3841 1         3 elsif (/\G (\S) /oxgc) { # q * *
3842 1         2 my $delimiter = $1;
3843 1 50       3 my $q_string = '';
  14 50       66  
    100          
    50          
3844 0         0 while (not /\G \z/oxgc) {
3845 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3846 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3847             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3848 13         26 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3849             }
3850             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3851 0         0 }
3852             }
3853             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3854             }
3855             }
3856              
3857 0         0 # m//
3858 209 50       504 elsif (/\G \b (m) \b /oxgc) {
3859 209         1341 my $ope = $1;
3860             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3861             return e_qr($ope,$1,$3,$2,$4);
3862 0         0 }
3863 209         358 else {
3864 209 50       596 my $e = '';
  209 50       10681  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3865 0         0 while (not /\G \z/oxgc) {
3866 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3867 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3868 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3869 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3870 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3871 10         24 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3872 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3873             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3874 199         710 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3875             }
3876             die __FILE__, ": Search pattern not terminated\n";
3877             }
3878             }
3879              
3880             # s///
3881              
3882             # about [cegimosxpradlunbB]* (/cg modifier)
3883             #
3884             # P.67 Pattern-Matching Operators
3885             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3886 0         0  
3887             elsif (/\G \b (s) \b /oxgc) {
3888             my $ope = $1;
3889 97 100       257  
3890 97         2259 # $1 $2 $3 $4 $5 $6
3891             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3892             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3893 1         6 }
3894 96         176 else {
3895 96 50       277 my $e = '';
  96 50       11511  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3896             while (not /\G \z/oxgc) {
3897 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3898 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3899 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3900             while (not /\G \z/oxgc) {
3901 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3902 0         0 # $1 $2 $3 $4
3903 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3904 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3905 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3906 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3907 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3908 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3909 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3910             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3911 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912             }
3913             die __FILE__, ": Substitution replacement not terminated\n";
3914 0         0 }
3915 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3916 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3917             while (not /\G \z/oxgc) {
3918 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3919 0         0 # $1 $2 $3 $4
3920 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3921 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3922 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3923 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929             }
3930             die __FILE__, ": Substitution replacement not terminated\n";
3931 0         0 }
3932 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3933 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3934             while (not /\G \z/oxgc) {
3935 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3936 0         0 # $1 $2 $3 $4
3937 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944             }
3945             die __FILE__, ": Substitution replacement not terminated\n";
3946 0         0 }
3947 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3948 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3949             while (not /\G \z/oxgc) {
3950 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3951 0         0 # $1 $2 $3 $4
3952 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961             }
3962             die __FILE__, ": Substitution replacement not terminated\n";
3963             }
3964 0         0 # $1 $2 $3 $4 $5 $6
3965             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3966             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3967             }
3968 21         67 # $1 $2 $3 $4 $5 $6
3969             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3970             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3971             }
3972 0         0 # $1 $2 $3 $4 $5 $6
3973             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3974             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3975             }
3976 0         0 # $1 $2 $3 $4 $5 $6
3977             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3978             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3979 75         321 }
3980             }
3981             die __FILE__, ": Substitution pattern not terminated\n";
3982             }
3983             }
3984 0         0  
3985 0         0 # require ignore module
3986 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3987             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3988             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3989 0         0  
3990 37         293 # use strict; --> use strict; no strict qw(refs);
3991 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3992             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3993             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3994              
3995 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
3996 2         23 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3997             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
3998             return "use $1; no strict qw(refs);";
3999 0         0 }
4000             else {
4001             return "use $1;";
4002             }
4003 2 0 0     11 }
      0        
4004 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4005             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4006             return "use $1; no strict qw(refs);";
4007 0         0 }
4008             else {
4009             return "use $1;";
4010             }
4011             }
4012 0         0  
4013 2         14 # ignore use module
4014 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4015             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4016             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4017 0         0  
4018 0         0 # ignore no module
4019 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4020             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4021             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4022 0         0  
4023             # use else
4024             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4025 0         0  
4026             # use else
4027             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4028              
4029 2         9 # ''
4030 848         1817 elsif (/\G (?
4031 848 100       2282 my $q_string = '';
  8254 100       27426  
    100          
    50          
4032 4         12 while (not /\G \z/oxgc) {
4033 48         92 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4034 848         3090 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4035             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4036 7354         14578 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4037             }
4038             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4039             }
4040              
4041 0         0 # ""
4042 1764         3682 elsif (/\G (\") /oxgc) {
4043 1764 100       4509 my $qq_string = '';
  34989 100       127146  
    100          
    50          
4044 67         160 while (not /\G \z/oxgc) {
4045 12         28 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4046 1764         4286 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4047             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4048 33146         72055 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4049             }
4050             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4051             }
4052              
4053 0         0 # ``
4054 1         3 elsif (/\G (\`) /oxgc) {
4055 1 50       4 my $qx_string = '';
  19 50       67  
    100          
    50          
4056 0         0 while (not /\G \z/oxgc) {
4057 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4058 1         2 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4059             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4060 18         32 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4061             }
4062             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4063             }
4064              
4065 0         0 # // --- not divide operator (num / num), not defined-or
4066 453         1431 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4067 453 50       1308 my $regexp = '';
  4496 50       20192  
    100          
    50          
4068 0         0 while (not /\G \z/oxgc) {
4069 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4070 453         1936 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4071             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4072 4043         8170 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4073             }
4074             die __FILE__, ": Search pattern not terminated\n";
4075             }
4076              
4077 0         0 # ?? --- not conditional operator (condition ? then : else)
4078 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4079 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4080 0         0 while (not /\G \z/oxgc) {
4081 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4082 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4083             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4084 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4085             }
4086             die __FILE__, ": Search pattern not terminated\n";
4087             }
4088 0         0  
  0         0  
4089             # <<>> (a safer ARGV)
4090             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4091 0         0  
  0         0  
4092             # << (bit shift) --- not here document
4093             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4094              
4095 0         0 # <<~'HEREDOC'
4096 6         92 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4097 6         18 $slash = 'm//';
4098             my $here_quote = $1;
4099             my $delimiter = $2;
4100 6 50       7  
4101 6         28 # get here document
4102 6         28 if ($here_script eq '') {
4103             $here_script = CORE::substr $_, pos $_;
4104 6 50       88 $here_script =~ s/.*?\n//oxm;
4105 6         75 }
4106 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4107 6         8 my $heredoc = $1;
4108 6         58 my $indent = $2;
4109 6         19 $heredoc =~ s{^$indent}{}msg; # no /ox
4110             push @heredoc, $heredoc . qq{\n$delimiter\n};
4111             push @heredoc_delimiter, qq{\\s*$delimiter};
4112 6         164 }
4113             else {
4114 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4115             }
4116             return qq{<<'$delimiter'};
4117             }
4118              
4119             # <<~\HEREDOC
4120              
4121             # P.66 2.6.6. "Here" Documents
4122             # in Chapter 2: Bits and Pieces
4123             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4124              
4125             # P.73 "Here" Documents
4126             # in Chapter 2: Bits and Pieces
4127             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4128 6         28  
4129 3         12 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4130 3         8 $slash = 'm//';
4131             my $here_quote = $1;
4132             my $delimiter = $2;
4133 3 50       8  
4134 3         11 # get here document
4135 3         45 if ($here_script eq '') {
4136             $here_script = CORE::substr $_, pos $_;
4137 3 50       24 $here_script =~ s/.*?\n//oxm;
4138 3         50 }
4139 3         49 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4140 3         9 my $heredoc = $1;
4141 3         47 my $indent = $2;
4142 3         99 $heredoc =~ s{^$indent}{}msg; # no /ox
4143             push @heredoc, $heredoc . qq{\n$delimiter\n};
4144             push @heredoc_delimiter, qq{\\s*$delimiter};
4145 3         13 }
4146             else {
4147 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4148             }
4149             return qq{<<\\$delimiter};
4150             }
4151              
4152 3         16 # <<~"HEREDOC"
4153 6         14 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4154 6         14 $slash = 'm//';
4155             my $here_quote = $1;
4156             my $delimiter = $2;
4157 6 50       7  
4158 6         12 # get here document
4159 6         26 if ($here_script eq '') {
4160             $here_script = CORE::substr $_, pos $_;
4161 6 50       30 $here_script =~ s/.*?\n//oxm;
4162 6         64 }
4163 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4164 6         8 my $heredoc = $1;
4165 6         42 my $indent = $2;
4166 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4167             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4168             push @heredoc_delimiter, qq{\\s*$delimiter};
4169 6         13 }
4170             else {
4171 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4172             }
4173             return qq{<<"$delimiter"};
4174             }
4175              
4176 6         24 # <<~HEREDOC
4177 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4178 3         7 $slash = 'm//';
4179             my $here_quote = $1;
4180             my $delimiter = $2;
4181 3 50       5  
4182 3         7 # get here document
4183 3         12 if ($here_script eq '') {
4184             $here_script = CORE::substr $_, pos $_;
4185 3 50       22 $here_script =~ s/.*?\n//oxm;
4186 3         38 }
4187 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4188 3         5 my $heredoc = $1;
4189 3         42 my $indent = $2;
4190 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
4191             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4192             push @heredoc_delimiter, qq{\\s*$delimiter};
4193 3         8 }
4194             else {
4195 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4196             }
4197             return qq{<<$delimiter};
4198             }
4199              
4200 3         12 # <<~`HEREDOC`
4201 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4202 6         11 $slash = 'm//';
4203             my $here_quote = $1;
4204             my $delimiter = $2;
4205 6 50       9  
4206 6         12 # get here document
4207 6         30 if ($here_script eq '') {
4208             $here_script = CORE::substr $_, pos $_;
4209 6 50       33 $here_script =~ s/.*?\n//oxm;
4210 6         65 }
4211 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4212 6         8 my $heredoc = $1;
4213 6         49 my $indent = $2;
4214 6         16 $heredoc =~ s{^$indent}{}msg; # no /ox
4215             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4216             push @heredoc_delimiter, qq{\\s*$delimiter};
4217 6         14 }
4218             else {
4219 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4220             }
4221             return qq{<<`$delimiter`};
4222             }
4223              
4224 6         23 # <<'HEREDOC'
4225 72         166 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4226 72         149 $slash = 'm//';
4227             my $here_quote = $1;
4228             my $delimiter = $2;
4229 72 50       119  
4230 72         327 # get here document
4231 72         378 if ($here_script eq '') {
4232             $here_script = CORE::substr $_, pos $_;
4233 72 50       411 $here_script =~ s/.*?\n//oxm;
4234 72         642 }
4235 72         412 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4236             push @heredoc, $1 . qq{\n$delimiter\n};
4237             push @heredoc_delimiter, $delimiter;
4238 72         253 }
4239             else {
4240 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4241             }
4242             return $here_quote;
4243             }
4244              
4245             # <<\HEREDOC
4246              
4247             # P.66 2.6.6. "Here" Documents
4248             # in Chapter 2: Bits and Pieces
4249             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4250              
4251             # P.73 "Here" Documents
4252             # in Chapter 2: Bits and Pieces
4253             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4254 72         284  
4255 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4256 0         0 $slash = 'm//';
4257             my $here_quote = $1;
4258             my $delimiter = $2;
4259 0 0       0  
4260 0         0 # get here document
4261 0         0 if ($here_script eq '') {
4262             $here_script = CORE::substr $_, pos $_;
4263 0 0       0 $here_script =~ s/.*?\n//oxm;
4264 0         0 }
4265 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4266             push @heredoc, $1 . qq{\n$delimiter\n};
4267             push @heredoc_delimiter, $delimiter;
4268 0         0 }
4269             else {
4270 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4271             }
4272             return $here_quote;
4273             }
4274              
4275 0         0 # <<"HEREDOC"
4276 36         84 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4277 36         81 $slash = 'm//';
4278             my $here_quote = $1;
4279             my $delimiter = $2;
4280 36 50       64  
4281 36         93 # get here document
4282 36         324 if ($here_script eq '') {
4283             $here_script = CORE::substr $_, pos $_;
4284 36 50       256 $here_script =~ s/.*?\n//oxm;
4285 36         473 }
4286 36         117 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4287             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4288             push @heredoc_delimiter, $delimiter;
4289 36         79 }
4290             else {
4291 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4292             }
4293             return $here_quote;
4294             }
4295              
4296 36         146 # <
4297 42         151 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4298 42         170 $slash = 'm//';
4299             my $here_quote = $1;
4300             my $delimiter = $2;
4301 42 50       78  
4302 42         103 # get here document
4303 42         328 if ($here_script eq '') {
4304             $here_script = CORE::substr $_, pos $_;
4305 42 50       327 $here_script =~ s/.*?\n//oxm;
4306 42         611 }
4307 42         165 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4308             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4309             push @heredoc_delimiter, $delimiter;
4310 42         105 }
4311             else {
4312 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4313             }
4314             return $here_quote;
4315             }
4316              
4317 42         196 # <<`HEREDOC`
4318 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4319 0         0 $slash = 'm//';
4320             my $here_quote = $1;
4321             my $delimiter = $2;
4322 0 0       0  
4323 0         0 # get here document
4324 0         0 if ($here_script eq '') {
4325             $here_script = CORE::substr $_, pos $_;
4326 0 0       0 $here_script =~ s/.*?\n//oxm;
4327 0         0 }
4328 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4329             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4330             push @heredoc_delimiter, $delimiter;
4331 0         0 }
4332             else {
4333 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4334             }
4335             return $here_quote;
4336             }
4337              
4338 0         0 # <<= <=> <= < operator
4339             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4340             return $1;
4341             }
4342              
4343 12         69 #
4344             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4345             return $1;
4346             }
4347              
4348             # --- glob
4349              
4350             # avoid "Error: Runtime exception" of perl version 5.005_03
4351 0         0  
4352             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4353             return 'Elatin1::glob("' . $1 . '")';
4354             }
4355 0         0  
4356             # __DATA__
4357             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4358 0         0  
4359             # __END__
4360             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4361              
4362             # \cD Control-D
4363              
4364             # P.68 2.6.8. Other Literal Tokens
4365             # in Chapter 2: Bits and Pieces
4366             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4367              
4368             # P.76 Other Literal Tokens
4369             # in Chapter 2: Bits and Pieces
4370 204         1545 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4371              
4372             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4373 0         0  
4374             # \cZ Control-Z
4375             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4376              
4377             # any operator before div
4378             elsif (/\G (
4379             -- | \+\+ |
4380 0         0 [\)\}\]]
  5081         11750  
4381              
4382             ) /oxgc) { $slash = 'div'; return $1; }
4383              
4384             # yada-yada or triple-dot operator
4385             elsif (/\G (
4386 5081         23452 \.\.\.
  7         17  
4387              
4388             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4389              
4390             # any operator before m//
4391              
4392             # //, //= (defined-or)
4393              
4394             # P.164 Logical Operators
4395             # in Chapter 10: More Control Structures
4396             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4397              
4398             # P.119 C-Style Logical (Short-Circuit) Operators
4399             # in Chapter 3: Unary and Binary Operators
4400             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4401              
4402             # (and so on)
4403              
4404             # ~~
4405              
4406             # P.221 The Smart Match Operator
4407             # in Chapter 15: Smart Matching and given-when
4408             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4409              
4410             # P.112 Smartmatch Operator
4411             # in Chapter 3: Unary and Binary Operators
4412             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4413              
4414             # (and so on)
4415              
4416             elsif (/\G ((?>
4417              
4418             !~~ | !~ | != | ! |
4419             %= | % |
4420             &&= | && | &= | &\.= | &\. | & |
4421             -= | -> | - |
4422             :(?>\s*)= |
4423             : |
4424             <<>> |
4425             <<= | <=> | <= | < |
4426             == | => | =~ | = |
4427             >>= | >> | >= | > |
4428             \*\*= | \*\* | \*= | \* |
4429             \+= | \+ |
4430             \.\. | \.= | \. |
4431             \/\/= | \/\/ |
4432             \/= | \/ |
4433             \? |
4434             \\ |
4435             \^= | \^\.= | \^\. | \^ |
4436             \b x= |
4437             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4438             ~~ | ~\. | ~ |
4439             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4440             \b(?: print )\b |
4441              
4442 7         30 [,;\(\{\[]
  8826         18809  
4443              
4444             )) /oxgc) { $slash = 'm//'; return $1; }
4445 8826         69982  
  15137         30642  
4446             # other any character
4447             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4448              
4449 15137         77492 # system error
4450             else {
4451             die __FILE__, ": Oops, this shouldn't happen!\n";
4452             }
4453             }
4454              
4455 0     1786 0 0 # escape Latin-1 string
4456 1786         4247 sub e_string {
4457             my($string) = @_;
4458 1786         2751 my $e_string = '';
4459              
4460             local $slash = 'm//';
4461              
4462             # P.1024 Appendix W.10 Multibyte Processing
4463             # of ISBN 1-56592-224-7 CJKV Information Processing
4464 1786         3257 # (and so on)
4465              
4466             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4467 1786 100 66     14623  
4468 1786 50       7535 # without { ... }
4469 1769         4635 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4470             if ($string !~ /<
4471             return $string;
4472             }
4473             }
4474 1769         4463  
4475 17 50       158 E_STRING_LOOP:
    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          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4476             while ($string !~ /\G \z/oxgc) {
4477             if (0) {
4478             }
4479 190         14452  
4480 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin1::PREMATCH()]}
4481 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4482             $e_string .= q{Elatin1::PREMATCH()};
4483             $slash = 'div';
4484             }
4485              
4486 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin1::MATCH()]}
4487 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4488             $e_string .= q{Elatin1::MATCH()};
4489             $slash = 'div';
4490             }
4491              
4492 0         0 # $', ${'} --> $', ${'}
4493 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4494             $e_string .= $1;
4495             $slash = 'div';
4496             }
4497              
4498 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin1::POSTMATCH()]}
4499 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4500             $e_string .= q{Elatin1::POSTMATCH()};
4501             $slash = 'div';
4502             }
4503              
4504 0         0 # bareword
4505 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4506             $e_string .= $1;
4507             $slash = 'div';
4508             }
4509              
4510 0         0 # $0 --> $0
4511 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4512             $e_string .= $1;
4513             $slash = 'div';
4514 0         0 }
4515 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4516             $e_string .= $1;
4517             $slash = 'div';
4518             }
4519              
4520 0         0 # $$ --> $$
4521 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4522             $e_string .= $1;
4523             $slash = 'div';
4524             }
4525              
4526             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4527 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4528 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4529             $e_string .= e_capture($1);
4530             $slash = 'div';
4531 0         0 }
4532 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4533             $e_string .= e_capture($1);
4534             $slash = 'div';
4535             }
4536              
4537 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4538 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4539             $e_string .= e_capture($1.'->'.$2);
4540             $slash = 'div';
4541             }
4542              
4543 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4544 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4545             $e_string .= e_capture($1.'->'.$2);
4546             $slash = 'div';
4547             }
4548              
4549 0         0 # $$foo
4550 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4551             $e_string .= e_capture($1);
4552             $slash = 'div';
4553             }
4554              
4555 0         0 # ${ foo }
4556 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4557             $e_string .= '${' . $1 . '}';
4558             $slash = 'div';
4559             }
4560              
4561 0         0 # ${ ... }
4562 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4563             $e_string .= e_capture($1);
4564             $slash = 'div';
4565             }
4566              
4567             # variable or function
4568 3         23 # $ @ % & * $ #
4569 7         18 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) {
4570             $e_string .= $1;
4571             $slash = 'div';
4572             }
4573             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4574 7         23 # $ @ # \ ' " / ? ( ) [ ] < >
4575 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4576             $e_string .= $1;
4577             $slash = 'div';
4578             }
4579 0         0  
  0         0  
4580 0         0 # subroutines of package Elatin1
  0         0  
4581 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4582 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4583 0         0 elsif ($string =~ /\G \b Latin1::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4584 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4585 0         0 elsif ($string =~ /\G \b Latin1::eval \b /oxgc) { $e_string .= 'eval Latin1::escape'; $slash = 'm//'; }
  0         0  
4586 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4587 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin1::chop'; $slash = 'm//'; }
  0         0  
4588 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4589 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4590 0         0 elsif ($string =~ /\G \b Latin1::index \b /oxgc) { $e_string .= 'Latin1::index'; $slash = 'm//'; }
  0         0  
4591 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin1::index'; $slash = 'm//'; }
  0         0  
4592 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4593 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4594 0         0 elsif ($string =~ /\G \b Latin1::rindex \b /oxgc) { $e_string .= 'Latin1::rindex'; $slash = 'm//'; }
  0         0  
4595 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin1::rindex'; $slash = 'm//'; }
  0         0  
4596 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::lc'; $slash = 'm//'; }
  0         0  
4597 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::lcfirst'; $slash = 'm//'; }
  0         0  
4598 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::uc'; $slash = 'm//'; }
  0         0  
4599             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::ucfirst'; $slash = 'm//'; }
4600             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::fc'; $slash = 'm//'; }
4601 0         0  
  0         0  
4602 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4603 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4604 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  
4605 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  
4606 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  
4607 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  
4608             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4609 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  
4610 0         0  
  0         0  
4611 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4612 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  
4613 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  
4614 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  
4615 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  
4616             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4617             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4618 0         0  
  0         0  
4619 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4620 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4621 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4622             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4623 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4624 0         0  
  0         0  
4625 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4626 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4627 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::chr'; $slash = 'm//'; }
  0         0  
4628 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4629 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4630 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin1::glob'; $slash = 'm//'; }
  0         0  
4631 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin1::lc_'; $slash = 'm//'; }
  0         0  
4632 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin1::lcfirst_'; $slash = 'm//'; }
  0         0  
4633 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin1::uc_'; $slash = 'm//'; }
  0         0  
4634 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin1::ucfirst_'; $slash = 'm//'; }
  0         0  
4635             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin1::fc_'; $slash = 'm//'; }
4636 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4637 0         0  
  0         0  
4638 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4639 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin1::chr_'; $slash = 'm//'; }
  0         0  
4641 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4642 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4643 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin1::glob_'; $slash = 'm//'; }
  0         0  
4644             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4645             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4646 0         0 # split
4647             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4648 0         0 $slash = 'm//';
4649 0         0  
4650 0         0 my $e = '';
4651             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4652             $e .= $1;
4653             }
4654 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4655             # end of split
4656             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin1::split' . $e; }
4657 0         0  
  0         0  
4658             # split scalar value
4659             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin1::split' . $e . e_string($1); next E_STRING_LOOP; }
4660 0         0  
  0         0  
4661 0         0 # split literal space
  0         0  
4662 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4663 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4664 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4665 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4666 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4667 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  
4668 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4669 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4670 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4671 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4673 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  
4674             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {' '}; next E_STRING_LOOP; }
4675             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin1::split' . $e . qq {" "}; next E_STRING_LOOP; }
4676              
4677 0 0       0 # split qq//
  0         0  
  0         0  
4678             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4679 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4680 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4681 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4682 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4683 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  
4684 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  
4685 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  
4686 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  
4687             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4688 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 * *
4689             }
4690             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4691             }
4692             }
4693              
4694 0 0       0 # split qr//
  0         0  
  0         0  
4695             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4696 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4697 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4698 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4699 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4700 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  
4701 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  
4702 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  
4703 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  
4704 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  
4705             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4706 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 * *
4707             }
4708             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4709             }
4710             }
4711              
4712 0 0       0 # split q//
  0         0  
  0         0  
4713             elsif ($string =~ /\G \b (q) \b /oxgc) {
4714 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4715 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4716 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4717 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4718 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  
4719 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  
4720 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  
4721 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  
4722             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4723 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 * *
4724             }
4725             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4726             }
4727             }
4728              
4729 0 0       0 # split m//
  0         0  
  0         0  
4730             elsif ($string =~ /\G \b (m) \b /oxgc) {
4731 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 # #
4732 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4733 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4734 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4735 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  
4736 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  
4737 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  
4738 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  
4739 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  
4740             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4741 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 * *
4742             }
4743             die __FILE__, ": Search pattern not terminated\n";
4744             }
4745             }
4746              
4747 0         0 # split ''
4748 0         0 elsif ($string =~ /\G (\') /oxgc) {
4749 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4750 0         0 while ($string !~ /\G \z/oxgc) {
4751 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4752 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4753             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4754 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4755             }
4756             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4757             }
4758              
4759 0         0 # split ""
4760 0         0 elsif ($string =~ /\G (\") /oxgc) {
4761 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4762 0         0 while ($string !~ /\G \z/oxgc) {
4763 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4764 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4765             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4766 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4767             }
4768             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4769             }
4770              
4771 0         0 # split //
4772 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4773 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4774 0         0 while ($string !~ /\G \z/oxgc) {
4775 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4776 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4777             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4778 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4779             }
4780             die __FILE__, ": Search pattern not terminated\n";
4781             }
4782             }
4783              
4784 0         0 # qq//
4785 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4786 0         0 my $ope = $1;
4787             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4788             $e_string .= e_qq($ope,$1,$3,$2);
4789 0         0 }
4790 0         0 else {
4791 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4792 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4793 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4794 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4795 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4796 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4797             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4798 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4799             }
4800             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4801             }
4802             }
4803              
4804 0         0 # qx//
4805 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4806 0         0 my $ope = $1;
4807             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4808             $e_string .= e_qq($ope,$1,$3,$2);
4809 0         0 }
4810 0         0 else {
4811 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4812 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4813 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4814 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4815 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4816 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4817 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4818             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4819 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4820             }
4821             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4822             }
4823             }
4824              
4825 0         0 # q//
4826 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4827 0         0 my $ope = $1;
4828             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4829             $e_string .= e_q($ope,$1,$3,$2);
4830 0         0 }
4831 0         0 else {
4832 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4833 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4834 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4835 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4836 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4837 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4838             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4839 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 * *
4840             }
4841             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4842             }
4843             }
4844 0         0  
4845             # ''
4846             elsif ($string =~ /\G (?
4847 0         0  
4848             # ""
4849             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4850 0         0  
4851             # ``
4852             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4853 0         0  
4854             # <<>> (a safer ARGV)
4855             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4856 0         0  
4857             # <<= <=> <= < operator
4858             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4859 0         0  
4860             #
4861             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4862              
4863 0         0 # --- glob
4864             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4865             $e_string .= 'Elatin1::glob("' . $1 . '")';
4866             }
4867              
4868 0         0 # << (bit shift) --- not here document
4869 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4870             $slash = 'm//';
4871             $e_string .= $1;
4872             }
4873              
4874 0         0 # <<~'HEREDOC'
4875 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4876 0         0 $slash = 'm//';
4877             my $here_quote = $1;
4878             my $delimiter = $2;
4879 0 0       0  
4880 0         0 # get here document
4881 0         0 if ($here_script eq '') {
4882             $here_script = CORE::substr $_, pos $_;
4883 0 0       0 $here_script =~ s/.*?\n//oxm;
4884 0         0 }
4885 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4886 0         0 my $heredoc = $1;
4887 0         0 my $indent = $2;
4888 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4889             push @heredoc, $heredoc . qq{\n$delimiter\n};
4890             push @heredoc_delimiter, qq{\\s*$delimiter};
4891 0         0 }
4892             else {
4893 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4894             }
4895             $e_string .= qq{<<'$delimiter'};
4896             }
4897              
4898 0         0 # <<~\HEREDOC
4899 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4900 0         0 $slash = 'm//';
4901             my $here_quote = $1;
4902             my $delimiter = $2;
4903 0 0       0  
4904 0         0 # get here document
4905 0         0 if ($here_script eq '') {
4906             $here_script = CORE::substr $_, pos $_;
4907 0 0       0 $here_script =~ s/.*?\n//oxm;
4908 0         0 }
4909 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4910 0         0 my $heredoc = $1;
4911 0         0 my $indent = $2;
4912 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4913             push @heredoc, $heredoc . qq{\n$delimiter\n};
4914             push @heredoc_delimiter, qq{\\s*$delimiter};
4915 0         0 }
4916             else {
4917 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4918             }
4919             $e_string .= qq{<<\\$delimiter};
4920             }
4921              
4922 0         0 # <<~"HEREDOC"
4923 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4924 0         0 $slash = 'm//';
4925             my $here_quote = $1;
4926             my $delimiter = $2;
4927 0 0       0  
4928 0         0 # get here document
4929 0         0 if ($here_script eq '') {
4930             $here_script = CORE::substr $_, pos $_;
4931 0 0       0 $here_script =~ s/.*?\n//oxm;
4932 0         0 }
4933 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4934 0         0 my $heredoc = $1;
4935 0         0 my $indent = $2;
4936 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4937             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4938             push @heredoc_delimiter, qq{\\s*$delimiter};
4939 0         0 }
4940             else {
4941 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4942             }
4943             $e_string .= qq{<<"$delimiter"};
4944             }
4945              
4946 0         0 # <<~HEREDOC
4947 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4948 0         0 $slash = 'm//';
4949             my $here_quote = $1;
4950             my $delimiter = $2;
4951 0 0       0  
4952 0         0 # get here document
4953 0         0 if ($here_script eq '') {
4954             $here_script = CORE::substr $_, pos $_;
4955 0 0       0 $here_script =~ s/.*?\n//oxm;
4956 0         0 }
4957 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4958 0         0 my $heredoc = $1;
4959 0         0 my $indent = $2;
4960 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4961             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4962             push @heredoc_delimiter, qq{\\s*$delimiter};
4963 0         0 }
4964             else {
4965 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4966             }
4967             $e_string .= qq{<<$delimiter};
4968             }
4969              
4970 0         0 # <<~`HEREDOC`
4971 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4972 0         0 $slash = 'm//';
4973             my $here_quote = $1;
4974             my $delimiter = $2;
4975 0 0       0  
4976 0         0 # get here document
4977 0         0 if ($here_script eq '') {
4978             $here_script = CORE::substr $_, pos $_;
4979 0 0       0 $here_script =~ s/.*?\n//oxm;
4980 0         0 }
4981 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4982 0         0 my $heredoc = $1;
4983 0         0 my $indent = $2;
4984 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4985             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4986             push @heredoc_delimiter, qq{\\s*$delimiter};
4987 0         0 }
4988             else {
4989 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4990             }
4991             $e_string .= qq{<<`$delimiter`};
4992             }
4993              
4994 0         0 # <<'HEREDOC'
4995 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4996 0         0 $slash = 'm//';
4997             my $here_quote = $1;
4998             my $delimiter = $2;
4999 0 0       0  
5000 0         0 # get here document
5001 0         0 if ($here_script eq '') {
5002             $here_script = CORE::substr $_, pos $_;
5003 0 0       0 $here_script =~ s/.*?\n//oxm;
5004 0         0 }
5005 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5006             push @heredoc, $1 . qq{\n$delimiter\n};
5007             push @heredoc_delimiter, $delimiter;
5008 0         0 }
5009             else {
5010 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5011             }
5012             $e_string .= $here_quote;
5013             }
5014              
5015 0         0 # <<\HEREDOC
5016 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5017 0         0 $slash = 'm//';
5018             my $here_quote = $1;
5019             my $delimiter = $2;
5020 0 0       0  
5021 0         0 # get here document
5022 0         0 if ($here_script eq '') {
5023             $here_script = CORE::substr $_, pos $_;
5024 0 0       0 $here_script =~ s/.*?\n//oxm;
5025 0         0 }
5026 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5027             push @heredoc, $1 . qq{\n$delimiter\n};
5028             push @heredoc_delimiter, $delimiter;
5029 0         0 }
5030             else {
5031 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5032             }
5033             $e_string .= $here_quote;
5034             }
5035              
5036 0         0 # <<"HEREDOC"
5037 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5038 0         0 $slash = 'm//';
5039             my $here_quote = $1;
5040             my $delimiter = $2;
5041 0 0       0  
5042 0         0 # get here document
5043 0         0 if ($here_script eq '') {
5044             $here_script = CORE::substr $_, pos $_;
5045 0 0       0 $here_script =~ s/.*?\n//oxm;
5046 0         0 }
5047 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5048             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5049             push @heredoc_delimiter, $delimiter;
5050 0         0 }
5051             else {
5052 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5053             }
5054             $e_string .= $here_quote;
5055             }
5056              
5057 0         0 # <
5058 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5059 0         0 $slash = 'm//';
5060             my $here_quote = $1;
5061             my $delimiter = $2;
5062 0 0       0  
5063 0         0 # get here document
5064 0         0 if ($here_script eq '') {
5065             $here_script = CORE::substr $_, pos $_;
5066 0 0       0 $here_script =~ s/.*?\n//oxm;
5067 0         0 }
5068 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5069             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5070             push @heredoc_delimiter, $delimiter;
5071 0         0 }
5072             else {
5073 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5074             }
5075             $e_string .= $here_quote;
5076             }
5077              
5078 0         0 # <<`HEREDOC`
5079 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5080 0         0 $slash = 'm//';
5081             my $here_quote = $1;
5082             my $delimiter = $2;
5083 0 0       0  
5084 0         0 # get here document
5085 0         0 if ($here_script eq '') {
5086             $here_script = CORE::substr $_, pos $_;
5087 0 0       0 $here_script =~ s/.*?\n//oxm;
5088 0         0 }
5089 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5090             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5091             push @heredoc_delimiter, $delimiter;
5092 0         0 }
5093             else {
5094 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5095             }
5096             $e_string .= $here_quote;
5097             }
5098              
5099             # any operator before div
5100             elsif ($string =~ /\G (
5101             -- | \+\+ |
5102 0         0 [\)\}\]]
  18         40  
5103              
5104             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5105              
5106             # yada-yada or triple-dot operator
5107             elsif ($string =~ /\G (
5108 18         71 \.\.\.
  0         0  
5109              
5110             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5111              
5112             # any operator before m//
5113             elsif ($string =~ /\G ((?>
5114              
5115             !~~ | !~ | != | ! |
5116             %= | % |
5117             &&= | && | &= | &\.= | &\. | & |
5118             -= | -> | - |
5119             :(?>\s*)= |
5120             : |
5121             <<>> |
5122             <<= | <=> | <= | < |
5123             == | => | =~ | = |
5124             >>= | >> | >= | > |
5125             \*\*= | \*\* | \*= | \* |
5126             \+= | \+ |
5127             \.\. | \.= | \. |
5128             \/\/= | \/\/ |
5129             \/= | \/ |
5130             \? |
5131             \\ |
5132             \^= | \^\.= | \^\. | \^ |
5133             \b x= |
5134             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5135             ~~ | ~\. | ~ |
5136             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5137             \b(?: print )\b |
5138              
5139 0         0 [,;\(\{\[]
  31         60  
5140              
5141             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5142 31         112  
5143             # other any character
5144             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5145              
5146 131         363 # system error
5147             else {
5148             die __FILE__, ": Oops, this shouldn't happen!\n";
5149             }
5150 0         0 }
5151              
5152             return $e_string;
5153             }
5154              
5155             #
5156             # character class
5157 17     1919 0 76 #
5158             sub character_class {
5159 1919 100       3865 my($char,$modifier) = @_;
5160 1919 100       3059  
5161 52         99 if ($char eq '.') {
5162             if ($modifier =~ /s/) {
5163             return '${Elatin1::dot_s}';
5164 17         38 }
5165             else {
5166             return '${Elatin1::dot}';
5167             }
5168 35         72 }
5169             else {
5170             return Elatin1::classic_character_class($char);
5171             }
5172             }
5173              
5174             #
5175             # escape capture ($1, $2, $3, ...)
5176             #
5177 1867     212 0 3280 sub e_capture {
5178              
5179             return join '', '${', $_[0], '}';
5180             }
5181              
5182             #
5183             # escape transliteration (tr/// or y///)
5184 212     3 0 735 #
5185 3         22 sub e_tr {
5186 3   50     6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5187             my $e_tr = '';
5188 3         6 $modifier ||= '';
5189              
5190             $slash = 'div';
5191 3         5  
5192             # quote character class 1
5193             $charclass = q_tr($charclass);
5194 3         8  
5195             # quote character class 2
5196             $charclass2 = q_tr($charclass2);
5197 3 50       6  
5198 3 0       11 # /b /B modifier
5199 0         0 if ($modifier =~ tr/bB//d) {
5200             if ($variable eq '') {
5201             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5202 0         0 }
5203             else {
5204             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5205             }
5206 0 100       0 }
5207 3         7 else {
5208             if ($variable eq '') {
5209             $e_tr = qq{Elatin1::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5210 2         8 }
5211             else {
5212             $e_tr = qq{Elatin1::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5213             }
5214             }
5215 1         5  
5216 3         5 # clear tr/// variable
5217             $tr_variable = '';
5218 3         5 $bind_operator = '';
5219              
5220             return $e_tr;
5221             }
5222              
5223             #
5224             # quote for escape transliteration (tr/// or y///)
5225 3     6 0 15 #
5226             sub q_tr {
5227             my($charclass) = @_;
5228 6 50       11  
    0          
    0          
    0          
    0          
    0          
5229 6         12 # quote character class
5230             if ($charclass !~ /'/oxms) {
5231             return e_q('', "'", "'", $charclass); # --> q' '
5232 6         11 }
5233             elsif ($charclass !~ /\//oxms) {
5234             return e_q('q', '/', '/', $charclass); # --> q/ /
5235 0         0 }
5236             elsif ($charclass !~ /\#/oxms) {
5237             return e_q('q', '#', '#', $charclass); # --> q# #
5238 0         0 }
5239             elsif ($charclass !~ /[\<\>]/oxms) {
5240             return e_q('q', '<', '>', $charclass); # --> q< >
5241 0         0 }
5242             elsif ($charclass !~ /[\(\)]/oxms) {
5243             return e_q('q', '(', ')', $charclass); # --> q( )
5244 0         0 }
5245             elsif ($charclass !~ /[\{\}]/oxms) {
5246             return e_q('q', '{', '}', $charclass); # --> q{ }
5247 0         0 }
5248 0 0       0 else {
5249 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5250             if ($charclass !~ /\Q$char\E/xms) {
5251             return e_q('q', $char, $char, $charclass);
5252             }
5253             }
5254 0         0 }
5255              
5256             return e_q('q', '{', '}', $charclass);
5257             }
5258              
5259             #
5260             # escape q string (q//, '')
5261 0     1264 0 0 #
5262             sub e_q {
5263 1264         3249 my($ope,$delimiter,$end_delimiter,$string) = @_;
5264              
5265 1264         1748 $slash = 'div';
5266              
5267             return join '', $ope, $delimiter, $string, $end_delimiter;
5268             }
5269              
5270             #
5271             # escape qq string (qq//, "", qx//, ``)
5272 1264     4026 0 6434 #
5273             sub e_qq {
5274 4026         9306 my($ope,$delimiter,$end_delimiter,$string) = @_;
5275              
5276 4026         5228 $slash = 'div';
5277 4026         5184  
5278             my $left_e = 0;
5279             my $right_e = 0;
5280 4026         4559  
5281             # split regexp
5282             my @char = $string =~ /\G((?>
5283             [^\\\$] |
5284             \\x\{ (?>[0-9A-Fa-f]+) \} |
5285             \\o\{ (?>[0-7]+) \} |
5286             \\N\{ (?>[^0-9\}][^\}]*) \} |
5287             \\ $q_char |
5288             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5289             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5290             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5291             \$ (?>\s* [0-9]+) |
5292             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5293             \$ \$ (?![\w\{]) |
5294             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5295             $q_char
5296 4026         175262 ))/oxmsg;
5297              
5298             for (my $i=0; $i <= $#char; $i++) {
5299 4026 50 33     20051  
    50 33        
    100          
    100          
    50          
5300 113721         383714 # "\L\u" --> "\u\L"
5301             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5302             @char[$i,$i+1] = @char[$i+1,$i];
5303             }
5304              
5305 0         0 # "\U\l" --> "\l\U"
5306             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5307             @char[$i,$i+1] = @char[$i+1,$i];
5308             }
5309              
5310 0         0 # octal escape sequence
5311             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5312             $char[$i] = Elatin1::octchr($1);
5313             }
5314              
5315 1         4 # hexadecimal escape sequence
5316             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5317             $char[$i] = Elatin1::hexchr($1);
5318             }
5319              
5320 1         3 # \N{CHARNAME} --> N{CHARNAME}
5321             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5322             $char[$i] = $1;
5323 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5324              
5325             if (0) {
5326             }
5327              
5328             # \F
5329             #
5330             # P.69 Table 2-6. Translation escapes
5331             # in Chapter 2: Bits and Pieces
5332             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5333             # (and so on)
5334 113721         1046936  
5335 0 50       0 # \u \l \U \L \F \Q \E
5336 484         1079 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5337             if ($right_e < $left_e) {
5338             $char[$i] = '\\' . $char[$i];
5339             }
5340             }
5341             elsif ($char[$i] eq '\u') {
5342              
5343             # "STRING @{[ LIST EXPR ]} MORE STRING"
5344              
5345             # P.257 Other Tricks You Can Do with Hard References
5346             # in Chapter 8: References
5347             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5348              
5349             # P.353 Other Tricks You Can Do with Hard References
5350             # in Chapter 8: References
5351             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5352              
5353 0         0 # (and so on)
5354 0         0  
5355             $char[$i] = '@{[Elatin1::ucfirst qq<';
5356             $left_e++;
5357 0         0 }
5358 0         0 elsif ($char[$i] eq '\l') {
5359             $char[$i] = '@{[Elatin1::lcfirst qq<';
5360             $left_e++;
5361 0         0 }
5362 0         0 elsif ($char[$i] eq '\U') {
5363             $char[$i] = '@{[Elatin1::uc qq<';
5364             $left_e++;
5365 0         0 }
5366 0         0 elsif ($char[$i] eq '\L') {
5367             $char[$i] = '@{[Elatin1::lc qq<';
5368             $left_e++;
5369 0         0 }
5370 24         32 elsif ($char[$i] eq '\F') {
5371             $char[$i] = '@{[Elatin1::fc qq<';
5372             $left_e++;
5373 24         44 }
5374 0         0 elsif ($char[$i] eq '\Q') {
5375             $char[$i] = '@{[CORE::quotemeta qq<';
5376             $left_e++;
5377 0 50       0 }
5378 24         44 elsif ($char[$i] eq '\E') {
5379 24         27 if ($right_e < $left_e) {
5380             $char[$i] = '>]}';
5381             $right_e++;
5382 24         42 }
5383             else {
5384             $char[$i] = '';
5385             }
5386 0         0 }
5387 0 0       0 elsif ($char[$i] eq '\Q') {
5388 0         0 while (1) {
5389             if (++$i > $#char) {
5390 0 0       0 last;
5391 0         0 }
5392             if ($char[$i] eq '\E') {
5393             last;
5394             }
5395             }
5396             }
5397             elsif ($char[$i] eq '\E') {
5398             }
5399              
5400             # $0 --> $0
5401             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5402             }
5403             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5404             }
5405              
5406             # $$ --> $$
5407             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5408             }
5409              
5410             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5411 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5412             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5413             $char[$i] = e_capture($1);
5414 205         371 }
5415             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5416             $char[$i] = e_capture($1);
5417             }
5418              
5419 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5420             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5421             $char[$i] = e_capture($1.'->'.$2);
5422             }
5423              
5424 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5425             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5426             $char[$i] = e_capture($1.'->'.$2);
5427             }
5428              
5429 0         0 # $$foo
5430             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5431             $char[$i] = e_capture($1);
5432             }
5433              
5434 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
5435             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5436             $char[$i] = '@{[Elatin1::PREMATCH()]}';
5437             }
5438              
5439 44         106 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
5440             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5441             $char[$i] = '@{[Elatin1::MATCH()]}';
5442             }
5443              
5444 45         142 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
5445             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5446             $char[$i] = '@{[Elatin1::POSTMATCH()]}';
5447             }
5448              
5449             # ${ foo } --> ${ foo }
5450             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5451             }
5452              
5453 33         143 # ${ ... }
5454             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5455             $char[$i] = e_capture($1);
5456             }
5457             }
5458 0 50       0  
5459 4026         8312 # return string
5460             if ($left_e > $right_e) {
5461 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5462             }
5463             return join '', $ope, $delimiter, @char, $end_delimiter;
5464             }
5465              
5466             #
5467             # escape qw string (qw//)
5468 4026     16 0 33624 #
5469             sub e_qw {
5470 16         83 my($ope,$delimiter,$end_delimiter,$string) = @_;
5471              
5472             $slash = 'div';
5473 16         37  
  16         224  
5474 483 50       735 # choice again delimiter
    0          
    0          
    0          
    0          
5475 16         133 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5476             if (not $octet{$end_delimiter}) {
5477             return join '', $ope, $delimiter, $string, $end_delimiter;
5478 16         136 }
5479             elsif (not $octet{')'}) {
5480             return join '', $ope, '(', $string, ')';
5481 0         0 }
5482             elsif (not $octet{'}'}) {
5483             return join '', $ope, '{', $string, '}';
5484 0         0 }
5485             elsif (not $octet{']'}) {
5486             return join '', $ope, '[', $string, ']';
5487 0         0 }
5488             elsif (not $octet{'>'}) {
5489             return join '', $ope, '<', $string, '>';
5490 0         0 }
5491 0 0       0 else {
5492 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5493             if (not $octet{$char}) {
5494             return join '', $ope, $char, $string, $char;
5495             }
5496             }
5497             }
5498 0         0  
5499 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5500 0         0 my @string = CORE::split(/\s+/, $string);
5501 0         0 for my $string (@string) {
5502 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5503 0         0 for my $octet (@octet) {
5504             if ($octet =~ /\A (['\\]) \z/oxms) {
5505             $octet = '\\' . $1;
5506 0         0 }
5507             }
5508 0         0 $string = join '', @octet;
  0         0  
5509             }
5510             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5511             }
5512              
5513             #
5514             # escape here document (<<"HEREDOC", <
5515 0     93 0 0 #
5516             sub e_heredoc {
5517 93         292 my($string) = @_;
5518              
5519 93         147 $slash = 'm//';
5520              
5521 93         299 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5522 93         139  
5523             my $left_e = 0;
5524             my $right_e = 0;
5525 93         118  
5526             # split regexp
5527             my @char = $string =~ /\G((?>
5528             [^\\\$] |
5529             \\x\{ (?>[0-9A-Fa-f]+) \} |
5530             \\o\{ (?>[0-7]+) \} |
5531             \\N\{ (?>[^0-9\}][^\}]*) \} |
5532             \\ $q_char |
5533             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5534             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5535             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5536             \$ (?>\s* [0-9]+) |
5537             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5538             \$ \$ (?![\w\{]) |
5539             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5540             $q_char
5541 93         7947 ))/oxmsg;
5542              
5543             for (my $i=0; $i <= $#char; $i++) {
5544 93 50 33     391  
    50 33        
    100          
    100          
    50          
5545 3177         9567 # "\L\u" --> "\u\L"
5546             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5547             @char[$i,$i+1] = @char[$i+1,$i];
5548             }
5549              
5550 0         0 # "\U\l" --> "\l\U"
5551             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5552             @char[$i,$i+1] = @char[$i+1,$i];
5553             }
5554              
5555 0         0 # octal escape sequence
5556             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5557             $char[$i] = Elatin1::octchr($1);
5558             }
5559              
5560 1         3 # hexadecimal escape sequence
5561             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5562             $char[$i] = Elatin1::hexchr($1);
5563             }
5564              
5565 1         3 # \N{CHARNAME} --> N{CHARNAME}
5566             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5567             $char[$i] = $1;
5568 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5569              
5570             if (0) {
5571             }
5572 3177         24974  
5573 0 0       0 # \u \l \U \L \F \Q \E
5574 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5575             if ($right_e < $left_e) {
5576             $char[$i] = '\\' . $char[$i];
5577             }
5578 0         0 }
5579 0         0 elsif ($char[$i] eq '\u') {
5580             $char[$i] = '@{[Elatin1::ucfirst qq<';
5581             $left_e++;
5582 0         0 }
5583 0         0 elsif ($char[$i] eq '\l') {
5584             $char[$i] = '@{[Elatin1::lcfirst qq<';
5585             $left_e++;
5586 0         0 }
5587 0         0 elsif ($char[$i] eq '\U') {
5588             $char[$i] = '@{[Elatin1::uc qq<';
5589             $left_e++;
5590 0         0 }
5591 0         0 elsif ($char[$i] eq '\L') {
5592             $char[$i] = '@{[Elatin1::lc qq<';
5593             $left_e++;
5594 0         0 }
5595 0         0 elsif ($char[$i] eq '\F') {
5596             $char[$i] = '@{[Elatin1::fc qq<';
5597             $left_e++;
5598 0         0 }
5599 0         0 elsif ($char[$i] eq '\Q') {
5600             $char[$i] = '@{[CORE::quotemeta qq<';
5601             $left_e++;
5602 0 0       0 }
5603 0         0 elsif ($char[$i] eq '\E') {
5604 0         0 if ($right_e < $left_e) {
5605             $char[$i] = '>]}';
5606             $right_e++;
5607 0         0 }
5608             else {
5609             $char[$i] = '';
5610             }
5611 0         0 }
5612 0 0       0 elsif ($char[$i] eq '\Q') {
5613 0         0 while (1) {
5614             if (++$i > $#char) {
5615 0 0       0 last;
5616 0         0 }
5617             if ($char[$i] eq '\E') {
5618             last;
5619             }
5620             }
5621             }
5622             elsif ($char[$i] eq '\E') {
5623             }
5624              
5625             # $0 --> $0
5626             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5627             }
5628             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5629             }
5630              
5631             # $$ --> $$
5632             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5633             }
5634              
5635             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5636 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5637             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5638             $char[$i] = e_capture($1);
5639 0         0 }
5640             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5641             $char[$i] = e_capture($1);
5642             }
5643              
5644 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5645             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5646             $char[$i] = e_capture($1.'->'.$2);
5647             }
5648              
5649 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5650             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5651             $char[$i] = e_capture($1.'->'.$2);
5652             }
5653              
5654 0         0 # $$foo
5655             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5656             $char[$i] = e_capture($1);
5657             }
5658              
5659 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
5660             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5661             $char[$i] = '@{[Elatin1::PREMATCH()]}';
5662             }
5663              
5664 8         42 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
5665             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5666             $char[$i] = '@{[Elatin1::MATCH()]}';
5667             }
5668              
5669 8         45 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
5670             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5671             $char[$i] = '@{[Elatin1::POSTMATCH()]}';
5672             }
5673              
5674             # ${ foo } --> ${ foo }
5675             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5676             }
5677              
5678 6         34 # ${ ... }
5679             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5680             $char[$i] = e_capture($1);
5681             }
5682             }
5683 0 50       0  
5684 93         205 # return string
5685             if ($left_e > $right_e) {
5686 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5687             }
5688             return join '', @char;
5689             }
5690              
5691             #
5692             # escape regexp (m//, qr//)
5693 93     652 0 693 #
5694 652   100     2713 sub e_qr {
5695             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5696 652         2650 $modifier ||= '';
5697 652 50       1096  
5698 652         1642 $modifier =~ tr/p//d;
5699 0         0 if ($modifier =~ /([adlu])/oxms) {
5700 0 0       0 my $line = 0;
5701 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5702 0         0 if ($filename ne __FILE__) {
5703             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5704             last;
5705 0         0 }
5706             }
5707             die qq{Unsupported modifier "$1" used at line $line.\n};
5708 0         0 }
5709              
5710             $slash = 'div';
5711 652 100       999  
    100          
5712 652         1921 # literal null string pattern
5713 8         11 if ($string eq '') {
5714 8         10 $modifier =~ tr/bB//d;
5715             $modifier =~ tr/i//d;
5716             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5717             }
5718              
5719             # /b /B modifier
5720             elsif ($modifier =~ tr/bB//d) {
5721 8 50       36  
5722 2         6 # choice again delimiter
5723 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5724 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5725 0         0 my %octet = map {$_ => 1} @char;
5726 0         0 if (not $octet{')'}) {
5727             $delimiter = '(';
5728             $end_delimiter = ')';
5729 0         0 }
5730 0         0 elsif (not $octet{'}'}) {
5731             $delimiter = '{';
5732             $end_delimiter = '}';
5733 0         0 }
5734 0         0 elsif (not $octet{']'}) {
5735             $delimiter = '[';
5736             $end_delimiter = ']';
5737 0         0 }
5738 0         0 elsif (not $octet{'>'}) {
5739             $delimiter = '<';
5740             $end_delimiter = '>';
5741 0         0 }
5742 0 0       0 else {
5743 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5744 0         0 if (not $octet{$char}) {
5745 0         0 $delimiter = $char;
5746             $end_delimiter = $char;
5747             last;
5748             }
5749             }
5750             }
5751 0 50 33     0 }
5752 2         9  
5753             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5754             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5755 0         0 }
5756             else {
5757             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5758             }
5759 2 100       11 }
5760 642         1377  
5761             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5762             my $metachar = qr/[\@\\|[\]{^]/oxms;
5763 642         2227  
5764             # split regexp
5765             my @char = $string =~ /\G((?>
5766             [^\\\$\@\[\(] |
5767             \\x (?>[0-9A-Fa-f]{1,2}) |
5768             \\ (?>[0-7]{2,3}) |
5769             \\c [\x40-\x5F] |
5770             \\x\{ (?>[0-9A-Fa-f]+) \} |
5771             \\o\{ (?>[0-7]+) \} |
5772             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5773             \\ $q_char |
5774             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5775             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5776             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5777             [\$\@] $qq_variable |
5778             \$ (?>\s* [0-9]+) |
5779             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5780             \$ \$ (?![\w\{]) |
5781             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5782             \[\^ |
5783             \[\: (?>[a-z]+) :\] |
5784             \[\:\^ (?>[a-z]+) :\] |
5785             \(\? |
5786             $q_char
5787             ))/oxmsg;
5788 642 50       70068  
5789 642         2988 # choice again delimiter
  0         0  
5790 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5791 0         0 my %octet = map {$_ => 1} @char;
5792 0         0 if (not $octet{')'}) {
5793             $delimiter = '(';
5794             $end_delimiter = ')';
5795 0         0 }
5796 0         0 elsif (not $octet{'}'}) {
5797             $delimiter = '{';
5798             $end_delimiter = '}';
5799 0         0 }
5800 0         0 elsif (not $octet{']'}) {
5801             $delimiter = '[';
5802             $end_delimiter = ']';
5803 0         0 }
5804 0         0 elsif (not $octet{'>'}) {
5805             $delimiter = '<';
5806             $end_delimiter = '>';
5807 0         0 }
5808 0 0       0 else {
5809 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5810 0         0 if (not $octet{$char}) {
5811 0         0 $delimiter = $char;
5812             $end_delimiter = $char;
5813             last;
5814             }
5815             }
5816             }
5817 0         0 }
5818 642         1515  
5819 642         794 my $left_e = 0;
5820             my $right_e = 0;
5821             for (my $i=0; $i <= $#char; $i++) {
5822 642 50 66     1668  
    50 66        
    100          
    100          
    100          
    100          
5823 1872         10835 # "\L\u" --> "\u\L"
5824             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5825             @char[$i,$i+1] = @char[$i+1,$i];
5826             }
5827              
5828 0         0 # "\U\l" --> "\l\U"
5829             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5830             @char[$i,$i+1] = @char[$i+1,$i];
5831             }
5832              
5833 0         0 # octal escape sequence
5834             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5835             $char[$i] = Elatin1::octchr($1);
5836             }
5837              
5838 1         4 # hexadecimal escape sequence
5839             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5840             $char[$i] = Elatin1::hexchr($1);
5841             }
5842              
5843             # \b{...} --> b\{...}
5844             # \B{...} --> B\{...}
5845             # \N{CHARNAME} --> N\{CHARNAME}
5846             # \p{PROPERTY} --> p\{PROPERTY}
5847 1         4 # \P{PROPERTY} --> P\{PROPERTY}
5848             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5849             $char[$i] = $1 . '\\' . $2;
5850             }
5851              
5852 6         18 # \p, \P, \X --> p, P, X
5853             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5854             $char[$i] = $1;
5855 4 100 100     11 }
    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          
5856              
5857             if (0) {
5858             }
5859 1872         5716  
5860 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5861 6         84 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5862             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)) {
5863             $char[$i] .= join '', splice @char, $i+1, 3;
5864 0         0 }
5865             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)) {
5866             $char[$i] .= join '', splice @char, $i+1, 2;
5867 0         0 }
5868             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)) {
5869             $char[$i] .= join '', splice @char, $i+1, 1;
5870             }
5871             }
5872              
5873 0         0 # open character class [...]
5874             elsif ($char[$i] eq '[') {
5875             my $left = $i;
5876              
5877             # [] make die "Unmatched [] in regexp ...\n"
5878 328 100       607 # (and so on)
5879 328         1020  
5880             if ($char[$i+1] eq ']') {
5881             $i++;
5882 3         6 }
5883 328 50       406  
5884 1379         2179 while (1) {
5885             if (++$i > $#char) {
5886 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5887 1379         2056 }
5888             if ($char[$i] eq ']') {
5889             my $right = $i;
5890 328 100       421  
5891 328         1637 # [...]
  30         70  
5892             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5893             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);
5894 90         134 }
5895             else {
5896             splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
5897 298         1052 }
5898 328         560  
5899             $i = $left;
5900             last;
5901             }
5902             }
5903             }
5904              
5905 328         919 # open character class [^...]
5906             elsif ($char[$i] eq '[^') {
5907             my $left = $i;
5908              
5909             # [^] make die "Unmatched [] in regexp ...\n"
5910 74 100       93 # (and so on)
5911 74         157  
5912             if ($char[$i+1] eq ']') {
5913             $i++;
5914 4         6 }
5915 74 50       87  
5916 272         381 while (1) {
5917             if (++$i > $#char) {
5918 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5919 272         403 }
5920             if ($char[$i] eq ']') {
5921             my $right = $i;
5922 74 100       93  
5923 74         337 # [^...]
  30         65  
5924             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5925             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);
5926 90         134 }
5927             else {
5928             splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5929 44         166 }
5930 74         145  
5931             $i = $left;
5932             last;
5933             }
5934             }
5935             }
5936              
5937 74         237 # rewrite character class or escape character
5938             elsif (my $char = character_class($char[$i],$modifier)) {
5939             $char[$i] = $char;
5940             }
5941              
5942 139 50       347 # /i modifier
5943 20         36 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
5944             if (CORE::length(Elatin1::fc($char[$i])) == 1) {
5945             $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
5946 20         30 }
5947             else {
5948             $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
5949             }
5950             }
5951              
5952 0 50       0 # \u \l \U \L \F \Q \E
5953 1         3 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5954             if ($right_e < $left_e) {
5955             $char[$i] = '\\' . $char[$i];
5956             }
5957 0         0 }
5958 0         0 elsif ($char[$i] eq '\u') {
5959             $char[$i] = '@{[Elatin1::ucfirst qq<';
5960             $left_e++;
5961 0         0 }
5962 0         0 elsif ($char[$i] eq '\l') {
5963             $char[$i] = '@{[Elatin1::lcfirst qq<';
5964             $left_e++;
5965 0         0 }
5966 1         4 elsif ($char[$i] eq '\U') {
5967             $char[$i] = '@{[Elatin1::uc qq<';
5968             $left_e++;
5969 1         4 }
5970 1         3 elsif ($char[$i] eq '\L') {
5971             $char[$i] = '@{[Elatin1::lc qq<';
5972             $left_e++;
5973 1         3 }
5974 18         28 elsif ($char[$i] eq '\F') {
5975             $char[$i] = '@{[Elatin1::fc qq<';
5976             $left_e++;
5977 18         38 }
5978 1         4 elsif ($char[$i] eq '\Q') {
5979             $char[$i] = '@{[CORE::quotemeta qq<';
5980             $left_e++;
5981 1 50       4 }
5982 21         41 elsif ($char[$i] eq '\E') {
5983 21         28 if ($right_e < $left_e) {
5984             $char[$i] = '>]}';
5985             $right_e++;
5986 21         45 }
5987             else {
5988             $char[$i] = '';
5989             }
5990 0         0 }
5991 0 0       0 elsif ($char[$i] eq '\Q') {
5992 0         0 while (1) {
5993             if (++$i > $#char) {
5994 0 0       0 last;
5995 0         0 }
5996             if ($char[$i] eq '\E') {
5997             last;
5998             }
5999             }
6000             }
6001             elsif ($char[$i] eq '\E') {
6002             }
6003              
6004 0 0       0 # $0 --> $0
6005 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6006             if ($ignorecase) {
6007             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6008             }
6009 0 0       0 }
6010 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6011             if ($ignorecase) {
6012             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6013             }
6014             }
6015              
6016             # $$ --> $$
6017             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6018             }
6019              
6020             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6021 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6022 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6023 0         0 $char[$i] = e_capture($1);
6024             if ($ignorecase) {
6025             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6026             }
6027 0         0 }
6028 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6029 0         0 $char[$i] = e_capture($1);
6030             if ($ignorecase) {
6031             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6032             }
6033             }
6034              
6035 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6036 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6037 0         0 $char[$i] = e_capture($1.'->'.$2);
6038             if ($ignorecase) {
6039             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6040             }
6041             }
6042              
6043 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6044 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6045 0         0 $char[$i] = e_capture($1.'->'.$2);
6046             if ($ignorecase) {
6047             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6048             }
6049             }
6050              
6051 0         0 # $$foo
6052 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6053 0         0 $char[$i] = e_capture($1);
6054             if ($ignorecase) {
6055             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6056             }
6057             }
6058              
6059 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
6060 8         20 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6061             if ($ignorecase) {
6062             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::PREMATCH())]}';
6063 0         0 }
6064             else {
6065             $char[$i] = '@{[Elatin1::PREMATCH()]}';
6066             }
6067             }
6068              
6069 8 50       24 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
6070 8         24 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6071             if ($ignorecase) {
6072             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::MATCH())]}';
6073 0         0 }
6074             else {
6075             $char[$i] = '@{[Elatin1::MATCH()]}';
6076             }
6077             }
6078              
6079 8 50       23 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
6080 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6081             if ($ignorecase) {
6082             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::POSTMATCH())]}';
6083 0         0 }
6084             else {
6085             $char[$i] = '@{[Elatin1::POSTMATCH()]}';
6086             }
6087             }
6088              
6089 6 0       16 # ${ foo }
6090 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6091             if ($ignorecase) {
6092             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6093             }
6094             }
6095              
6096 0         0 # ${ ... }
6097 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6098 0         0 $char[$i] = e_capture($1);
6099             if ($ignorecase) {
6100             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6101             }
6102             }
6103              
6104 0         0 # $scalar or @array
6105 21 100       50 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6106 21         118 $char[$i] = e_string($char[$i]);
6107             if ($ignorecase) {
6108             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6109             }
6110             }
6111              
6112 11 100 33     33 # quote character before ? + * {
    50          
6113             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6114             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6115 138         1049 }
6116 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6117 0         0 my $char = $char[$i-1];
6118             if ($char[$i] eq '{') {
6119             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6120 0         0 }
6121             else {
6122             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6123             }
6124 0         0 }
6125             else {
6126             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6127             }
6128             }
6129             }
6130 127         530  
6131 642 50       1227 # make regexp string
6132 642 0 0     1336 $modifier =~ tr/i//d;
6133 0         0 if ($left_e > $right_e) {
6134             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6135             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6136 0         0 }
6137             else {
6138             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6139 0 50 33     0 }
6140 642         3565 }
6141             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6142             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6143 0         0 }
6144             else {
6145             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6146             }
6147             }
6148              
6149             #
6150             # double quote stuff
6151 642     180 0 5279 #
6152             sub qq_stuff {
6153             my($delimiter,$end_delimiter,$stuff) = @_;
6154 180 100       322  
6155 180         341 # scalar variable or array variable
6156             if ($stuff =~ /\A [\$\@] /oxms) {
6157             return $stuff;
6158             }
6159 100         399  
  80         250  
6160 80         230 # quote by delimiter
6161 80 50       189 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6162 80 50       132 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6163 80 50       187 next if $char eq $delimiter;
6164 80         182 next if $char eq $end_delimiter;
6165             if (not $octet{$char}) {
6166             return join '', 'qq', $char, $stuff, $char;
6167 80         344 }
6168             }
6169             return join '', 'qq', '<', $stuff, '>';
6170             }
6171              
6172             #
6173             # escape regexp (m'', qr'', and m''b, qr''b)
6174 0     10 0 0 #
6175 10   50     37 sub e_qr_q {
6176             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6177 10         39 $modifier ||= '';
6178 10 50       15  
6179 10         17 $modifier =~ tr/p//d;
6180 0         0 if ($modifier =~ /([adlu])/oxms) {
6181 0 0       0 my $line = 0;
6182 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6183 0         0 if ($filename ne __FILE__) {
6184             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6185             last;
6186 0         0 }
6187             }
6188             die qq{Unsupported modifier "$1" used at line $line.\n};
6189 0         0 }
6190              
6191             $slash = 'div';
6192 10 100       13  
    50          
6193 10         19 # literal null string pattern
6194 8         10 if ($string eq '') {
6195 8         10 $modifier =~ tr/bB//d;
6196             $modifier =~ tr/i//d;
6197             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6198             }
6199              
6200 8         36 # with /b /B modifier
6201             elsif ($modifier =~ tr/bB//d) {
6202             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6203             }
6204              
6205 0         0 # without /b /B modifier
6206             else {
6207             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6208             }
6209             }
6210              
6211             #
6212             # escape regexp (m'', qr'')
6213 2     2 0 8 #
6214             sub e_qr_qt {
6215 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6216              
6217             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6218 2         5  
6219             # split regexp
6220             my @char = $string =~ /\G((?>
6221             [^\\\[\$\@\/] |
6222             [\x00-\xFF] |
6223             \[\^ |
6224             \[\: (?>[a-z]+) \:\] |
6225             \[\:\^ (?>[a-z]+) \:\] |
6226             [\$\@\/] |
6227             \\ (?:$q_char) |
6228             (?:$q_char)
6229             ))/oxmsg;
6230 2         57  
6231 2 50 33     7 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6232             for (my $i=0; $i <= $#char; $i++) {
6233             if (0) {
6234             }
6235 2         14  
6236 0         0 # open character class [...]
6237 0 0       0 elsif ($char[$i] eq '[') {
6238 0         0 my $left = $i;
6239             if ($char[$i+1] eq ']') {
6240 0         0 $i++;
6241 0 0       0 }
6242 0         0 while (1) {
6243             if (++$i > $#char) {
6244 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6245 0         0 }
6246             if ($char[$i] eq ']') {
6247             my $right = $i;
6248 0         0  
6249             # [...]
6250 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
6251 0         0  
6252             $i = $left;
6253             last;
6254             }
6255             }
6256             }
6257              
6258 0         0 # open character class [^...]
6259 0 0       0 elsif ($char[$i] eq '[^') {
6260 0         0 my $left = $i;
6261             if ($char[$i+1] eq ']') {
6262 0         0 $i++;
6263 0 0       0 }
6264 0         0 while (1) {
6265             if (++$i > $#char) {
6266 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6267 0         0 }
6268             if ($char[$i] eq ']') {
6269             my $right = $i;
6270 0         0  
6271             # [^...]
6272 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6273 0         0  
6274             $i = $left;
6275             last;
6276             }
6277             }
6278             }
6279              
6280 0         0 # escape $ @ / and \
6281             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6282             $char[$i] = '\\' . $char[$i];
6283             }
6284              
6285 0         0 # rewrite character class or escape character
6286             elsif (my $char = character_class($char[$i],$modifier)) {
6287             $char[$i] = $char;
6288             }
6289              
6290 0 0       0 # /i modifier
6291 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
6292             if (CORE::length(Elatin1::fc($char[$i])) == 1) {
6293             $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
6294 0         0 }
6295             else {
6296             $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
6297             }
6298             }
6299              
6300 0 0       0 # quote character before ? + * {
6301             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6302             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6303 0         0 }
6304             else {
6305             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6306             }
6307             }
6308 0         0 }
6309 2         5  
6310             $delimiter = '/';
6311 2         3 $end_delimiter = '/';
6312 2         3  
6313             $modifier =~ tr/i//d;
6314             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6315             }
6316              
6317             #
6318             # escape regexp (m''b, qr''b)
6319 2     0 0 13 #
6320             sub e_qr_qb {
6321             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6322 0         0  
6323             # split regexp
6324             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6325 0         0  
6326 0 0       0 # unescape character
    0          
6327             for (my $i=0; $i <= $#char; $i++) {
6328             if (0) {
6329             }
6330 0         0  
6331             # remain \\
6332             elsif ($char[$i] eq '\\\\') {
6333             }
6334              
6335 0         0 # escape $ @ / and \
6336             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6337             $char[$i] = '\\' . $char[$i];
6338             }
6339 0         0 }
6340 0         0  
6341 0         0 $delimiter = '/';
6342             $end_delimiter = '/';
6343             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6344             }
6345              
6346             #
6347             # escape regexp (s/here//)
6348 0     76 0 0 #
6349 76   100     281 sub e_s1 {
6350             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6351 76         358 $modifier ||= '';
6352 76 50       117  
6353 76         208 $modifier =~ tr/p//d;
6354 0         0 if ($modifier =~ /([adlu])/oxms) {
6355 0 0       0 my $line = 0;
6356 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6357 0         0 if ($filename ne __FILE__) {
6358             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6359             last;
6360 0         0 }
6361             }
6362             die qq{Unsupported modifier "$1" used at line $line.\n};
6363 0         0 }
6364              
6365             $slash = 'div';
6366 76 100       155  
    50          
6367 76         263 # literal null string pattern
6368 8         9 if ($string eq '') {
6369 8         8 $modifier =~ tr/bB//d;
6370             $modifier =~ tr/i//d;
6371             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6372             }
6373              
6374             # /b /B modifier
6375             elsif ($modifier =~ tr/bB//d) {
6376 8 0       40  
6377 0         0 # choice again delimiter
6378 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6379 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6380 0         0 my %octet = map {$_ => 1} @char;
6381 0         0 if (not $octet{')'}) {
6382             $delimiter = '(';
6383             $end_delimiter = ')';
6384 0         0 }
6385 0         0 elsif (not $octet{'}'}) {
6386             $delimiter = '{';
6387             $end_delimiter = '}';
6388 0         0 }
6389 0         0 elsif (not $octet{']'}) {
6390             $delimiter = '[';
6391             $end_delimiter = ']';
6392 0         0 }
6393 0         0 elsif (not $octet{'>'}) {
6394             $delimiter = '<';
6395             $end_delimiter = '>';
6396 0         0 }
6397 0 0       0 else {
6398 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6399 0         0 if (not $octet{$char}) {
6400 0         0 $delimiter = $char;
6401             $end_delimiter = $char;
6402             last;
6403             }
6404             }
6405             }
6406 0         0 }
6407 0         0  
6408             my $prematch = '';
6409             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6410 0 100       0 }
6411 68         258  
6412             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6413             my $metachar = qr/[\@\\|[\]{^]/oxms;
6414 68         447  
6415             # split regexp
6416             my @char = $string =~ /\G((?>
6417             [^\\\$\@\[\(] |
6418             \\ (?>[1-9][0-9]*) |
6419             \\g (?>\s*) (?>[1-9][0-9]*) |
6420             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6421             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6422             \\x (?>[0-9A-Fa-f]{1,2}) |
6423             \\ (?>[0-7]{2,3}) |
6424             \\c [\x40-\x5F] |
6425             \\x\{ (?>[0-9A-Fa-f]+) \} |
6426             \\o\{ (?>[0-7]+) \} |
6427             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6428             \\ $q_char |
6429             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6430             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6431             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6432             [\$\@] $qq_variable |
6433             \$ (?>\s* [0-9]+) |
6434             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6435             \$ \$ (?![\w\{]) |
6436             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6437             \[\^ |
6438             \[\: (?>[a-z]+) :\] |
6439             \[\:\^ (?>[a-z]+) :\] |
6440             \(\? |
6441             $q_char
6442             ))/oxmsg;
6443 68 50       16268  
6444 68         468 # choice again delimiter
  0         0  
6445 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6446 0         0 my %octet = map {$_ => 1} @char;
6447 0         0 if (not $octet{')'}) {
6448             $delimiter = '(';
6449             $end_delimiter = ')';
6450 0         0 }
6451 0         0 elsif (not $octet{'}'}) {
6452             $delimiter = '{';
6453             $end_delimiter = '}';
6454 0         0 }
6455 0         0 elsif (not $octet{']'}) {
6456             $delimiter = '[';
6457             $end_delimiter = ']';
6458 0         0 }
6459 0         0 elsif (not $octet{'>'}) {
6460             $delimiter = '<';
6461             $end_delimiter = '>';
6462 0         0 }
6463 0 0       0 else {
6464 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6465 0         0 if (not $octet{$char}) {
6466 0         0 $delimiter = $char;
6467             $end_delimiter = $char;
6468             last;
6469             }
6470             }
6471             }
6472             }
6473 0         0  
  68         159  
6474             # count '('
6475 253         431 my $parens = grep { $_ eq '(' } @char;
6476 68         111  
6477 68         106 my $left_e = 0;
6478             my $right_e = 0;
6479             for (my $i=0; $i <= $#char; $i++) {
6480 68 50 33     199  
    50 33        
    100          
    100          
    50          
    50          
6481 195         1108 # "\L\u" --> "\u\L"
6482             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6483             @char[$i,$i+1] = @char[$i+1,$i];
6484             }
6485              
6486 0         0 # "\U\l" --> "\l\U"
6487             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6488             @char[$i,$i+1] = @char[$i+1,$i];
6489             }
6490              
6491 0         0 # octal escape sequence
6492             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6493             $char[$i] = Elatin1::octchr($1);
6494             }
6495              
6496 1         4 # hexadecimal escape sequence
6497             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6498             $char[$i] = Elatin1::hexchr($1);
6499             }
6500              
6501             # \b{...} --> b\{...}
6502             # \B{...} --> B\{...}
6503             # \N{CHARNAME} --> N\{CHARNAME}
6504             # \p{PROPERTY} --> p\{PROPERTY}
6505 1         4 # \P{PROPERTY} --> P\{PROPERTY}
6506             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6507             $char[$i] = $1 . '\\' . $2;
6508             }
6509              
6510 0         0 # \p, \P, \X --> p, P, X
6511             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6512             $char[$i] = $1;
6513 0 50 66     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          
6514              
6515             if (0) {
6516             }
6517 195         691  
6518 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6519 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6520             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)) {
6521             $char[$i] .= join '', splice @char, $i+1, 3;
6522 0         0 }
6523             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)) {
6524             $char[$i] .= join '', splice @char, $i+1, 2;
6525 0         0 }
6526             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)) {
6527             $char[$i] .= join '', splice @char, $i+1, 1;
6528             }
6529             }
6530              
6531 0         0 # open character class [...]
6532 13 50       19 elsif ($char[$i] eq '[') {
6533 13         51 my $left = $i;
6534             if ($char[$i+1] eq ']') {
6535 0         0 $i++;
6536 13 50       19 }
6537 58         84 while (1) {
6538             if (++$i > $#char) {
6539 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6540 58         145 }
6541             if ($char[$i] eq ']') {
6542             my $right = $i;
6543 13 50       22  
6544 13         74 # [...]
  0         0  
6545             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6546             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);
6547 0         0 }
6548             else {
6549             splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
6550 13         53 }
6551 13         28  
6552             $i = $left;
6553             last;
6554             }
6555             }
6556             }
6557              
6558 13         52 # open character class [^...]
6559 0 0       0 elsif ($char[$i] eq '[^') {
6560 0         0 my $left = $i;
6561             if ($char[$i+1] eq ']') {
6562 0         0 $i++;
6563 0 0       0 }
6564 0         0 while (1) {
6565             if (++$i > $#char) {
6566 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6567 0         0 }
6568             if ($char[$i] eq ']') {
6569             my $right = $i;
6570 0 0       0  
6571 0         0 # [^...]
  0         0  
6572             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6573             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);
6574 0         0 }
6575             else {
6576             splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6577 0         0 }
6578 0         0  
6579             $i = $left;
6580             last;
6581             }
6582             }
6583             }
6584              
6585 0         0 # rewrite character class or escape character
6586             elsif (my $char = character_class($char[$i],$modifier)) {
6587             $char[$i] = $char;
6588             }
6589              
6590 7 50       17 # /i modifier
6591 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
6592             if (CORE::length(Elatin1::fc($char[$i])) == 1) {
6593             $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
6594 3         5 }
6595             else {
6596             $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
6597             }
6598             }
6599              
6600 0 0       0 # \u \l \U \L \F \Q \E
6601 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6602             if ($right_e < $left_e) {
6603             $char[$i] = '\\' . $char[$i];
6604             }
6605 0         0 }
6606 0         0 elsif ($char[$i] eq '\u') {
6607             $char[$i] = '@{[Elatin1::ucfirst qq<';
6608             $left_e++;
6609 0         0 }
6610 0         0 elsif ($char[$i] eq '\l') {
6611             $char[$i] = '@{[Elatin1::lcfirst qq<';
6612             $left_e++;
6613 0         0 }
6614 0         0 elsif ($char[$i] eq '\U') {
6615             $char[$i] = '@{[Elatin1::uc qq<';
6616             $left_e++;
6617 0         0 }
6618 0         0 elsif ($char[$i] eq '\L') {
6619             $char[$i] = '@{[Elatin1::lc qq<';
6620             $left_e++;
6621 0         0 }
6622 0         0 elsif ($char[$i] eq '\F') {
6623             $char[$i] = '@{[Elatin1::fc qq<';
6624             $left_e++;
6625 0         0 }
6626 0         0 elsif ($char[$i] eq '\Q') {
6627             $char[$i] = '@{[CORE::quotemeta qq<';
6628             $left_e++;
6629 0 0       0 }
6630 0         0 elsif ($char[$i] eq '\E') {
6631 0         0 if ($right_e < $left_e) {
6632             $char[$i] = '>]}';
6633             $right_e++;
6634 0         0 }
6635             else {
6636             $char[$i] = '';
6637             }
6638 0         0 }
6639 0 0       0 elsif ($char[$i] eq '\Q') {
6640 0         0 while (1) {
6641             if (++$i > $#char) {
6642 0 0       0 last;
6643 0         0 }
6644             if ($char[$i] eq '\E') {
6645             last;
6646             }
6647             }
6648             }
6649             elsif ($char[$i] eq '\E') {
6650             }
6651              
6652             # \0 --> \0
6653             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6654             }
6655              
6656             # \g{N}, \g{-N}
6657              
6658             # P.108 Using Simple Patterns
6659             # in Chapter 7: In the World of Regular Expressions
6660             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6661              
6662             # P.221 Capturing
6663             # in Chapter 5: Pattern Matching
6664             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6665              
6666             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6667             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6668             }
6669              
6670             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6671             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6672             }
6673              
6674             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6675             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6676             }
6677              
6678             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6679             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6680             }
6681              
6682 0 0       0 # $0 --> $0
6683 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6684             if ($ignorecase) {
6685             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6686             }
6687 0 0       0 }
6688 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6689             if ($ignorecase) {
6690             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6691             }
6692             }
6693              
6694             # $$ --> $$
6695             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6696             }
6697              
6698             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6699 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6700 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6701 0         0 $char[$i] = e_capture($1);
6702             if ($ignorecase) {
6703             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6704             }
6705 0         0 }
6706 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6707 0         0 $char[$i] = e_capture($1);
6708             if ($ignorecase) {
6709             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6710             }
6711             }
6712              
6713 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6714 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6715 0         0 $char[$i] = e_capture($1.'->'.$2);
6716             if ($ignorecase) {
6717             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6718             }
6719             }
6720              
6721 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6722 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6723 0         0 $char[$i] = e_capture($1.'->'.$2);
6724             if ($ignorecase) {
6725             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6726             }
6727             }
6728              
6729 0         0 # $$foo
6730 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6731 0         0 $char[$i] = e_capture($1);
6732             if ($ignorecase) {
6733             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6734             }
6735             }
6736              
6737 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
6738 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6739             if ($ignorecase) {
6740             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::PREMATCH())]}';
6741 0         0 }
6742             else {
6743             $char[$i] = '@{[Elatin1::PREMATCH()]}';
6744             }
6745             }
6746              
6747 4 50       13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
6748 4         24 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6749             if ($ignorecase) {
6750             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::MATCH())]}';
6751 0         0 }
6752             else {
6753             $char[$i] = '@{[Elatin1::MATCH()]}';
6754             }
6755             }
6756              
6757 4 50       14 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
6758 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6759             if ($ignorecase) {
6760             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::POSTMATCH())]}';
6761 0         0 }
6762             else {
6763             $char[$i] = '@{[Elatin1::POSTMATCH()]}';
6764             }
6765             }
6766              
6767 3 0       12 # ${ foo }
6768 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6769             if ($ignorecase) {
6770             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6771             }
6772             }
6773              
6774 0         0 # ${ ... }
6775 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6776 0         0 $char[$i] = e_capture($1);
6777             if ($ignorecase) {
6778             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6779             }
6780             }
6781              
6782 0         0 # $scalar or @array
6783 4 50       22 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6784 4         21 $char[$i] = e_string($char[$i]);
6785             if ($ignorecase) {
6786             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
6787             }
6788             }
6789              
6790 0 50       0 # quote character before ? + * {
6791             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6792             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6793 13         70 }
6794             else {
6795             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6796             }
6797             }
6798             }
6799 13         67  
6800 68         151 # make regexp string
6801 68 50       112 my $prematch = '';
6802 68         182 $modifier =~ tr/i//d;
6803             if ($left_e > $right_e) {
6804 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6805             }
6806             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6807             }
6808              
6809             #
6810             # escape regexp (s'here'' or s'here''b)
6811 68     21 0 800 #
6812 21   100     57 sub e_s1_q {
6813             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6814 21         68 $modifier ||= '';
6815 21 50       26  
6816 21         42 $modifier =~ tr/p//d;
6817 0         0 if ($modifier =~ /([adlu])/oxms) {
6818 0 0       0 my $line = 0;
6819 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6820 0         0 if ($filename ne __FILE__) {
6821             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6822             last;
6823 0         0 }
6824             }
6825             die qq{Unsupported modifier "$1" used at line $line.\n};
6826 0         0 }
6827              
6828             $slash = 'div';
6829 21 100       28  
    50          
6830 21         59 # literal null string pattern
6831 8         9 if ($string eq '') {
6832 8         9 $modifier =~ tr/bB//d;
6833             $modifier =~ tr/i//d;
6834             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6835             }
6836              
6837 8         42 # with /b /B modifier
6838             elsif ($modifier =~ tr/bB//d) {
6839             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6840             }
6841              
6842 0         0 # without /b /B modifier
6843             else {
6844             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6845             }
6846             }
6847              
6848             #
6849             # escape regexp (s'here'')
6850 13     13 0 35 #
6851             sub e_s1_qt {
6852 13 50       29 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6853              
6854             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6855 13         32  
6856             # split regexp
6857             my @char = $string =~ /\G((?>
6858             [^\\\[\$\@\/] |
6859             [\x00-\xFF] |
6860             \[\^ |
6861             \[\: (?>[a-z]+) \:\] |
6862             \[\:\^ (?>[a-z]+) \:\] |
6863             [\$\@\/] |
6864             \\ (?:$q_char) |
6865             (?:$q_char)
6866             ))/oxmsg;
6867 13         216  
6868 13 50 33     45 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6869             for (my $i=0; $i <= $#char; $i++) {
6870             if (0) {
6871             }
6872 25         101  
6873 0         0 # open character class [...]
6874 0 0       0 elsif ($char[$i] eq '[') {
6875 0         0 my $left = $i;
6876             if ($char[$i+1] eq ']') {
6877 0         0 $i++;
6878 0 0       0 }
6879 0         0 while (1) {
6880             if (++$i > $#char) {
6881 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6882 0         0 }
6883             if ($char[$i] eq ']') {
6884             my $right = $i;
6885 0         0  
6886             # [...]
6887 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
6888 0         0  
6889             $i = $left;
6890             last;
6891             }
6892             }
6893             }
6894              
6895 0         0 # open character class [^...]
6896 0 0       0 elsif ($char[$i] eq '[^') {
6897 0         0 my $left = $i;
6898             if ($char[$i+1] eq ']') {
6899 0         0 $i++;
6900 0 0       0 }
6901 0         0 while (1) {
6902             if (++$i > $#char) {
6903 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6904 0         0 }
6905             if ($char[$i] eq ']') {
6906             my $right = $i;
6907 0         0  
6908             # [^...]
6909 0         0 splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6910 0         0  
6911             $i = $left;
6912             last;
6913             }
6914             }
6915             }
6916              
6917 0         0 # escape $ @ / and \
6918             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6919             $char[$i] = '\\' . $char[$i];
6920             }
6921              
6922 0         0 # rewrite character class or escape character
6923             elsif (my $char = character_class($char[$i],$modifier)) {
6924             $char[$i] = $char;
6925             }
6926              
6927 6 0       13 # /i modifier
6928 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
6929             if (CORE::length(Elatin1::fc($char[$i])) == 1) {
6930             $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
6931 0         0 }
6932             else {
6933             $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
6934             }
6935             }
6936              
6937 0 0       0 # quote character before ? + * {
6938             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6939             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6940 0         0 }
6941             else {
6942             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6943             }
6944             }
6945 0         0 }
6946 13         30  
6947 13         22 $modifier =~ tr/i//d;
6948 13         18 $delimiter = '/';
6949 13         23 $end_delimiter = '/';
6950             my $prematch = '';
6951             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6952             }
6953              
6954             #
6955             # escape regexp (s'here''b)
6956 13     0 0 100 #
6957             sub e_s1_qb {
6958             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6959 0         0  
6960             # split regexp
6961             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6962 0         0  
6963 0 0       0 # unescape character
    0          
6964             for (my $i=0; $i <= $#char; $i++) {
6965             if (0) {
6966             }
6967 0         0  
6968             # remain \\
6969             elsif ($char[$i] eq '\\\\') {
6970             }
6971              
6972 0         0 # escape $ @ / and \
6973             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6974             $char[$i] = '\\' . $char[$i];
6975             }
6976 0         0 }
6977 0         0  
6978 0         0 $delimiter = '/';
6979 0         0 $end_delimiter = '/';
6980             my $prematch = '';
6981             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6982             }
6983              
6984             #
6985             # escape regexp (s''here')
6986 0     16 0 0 #
6987             sub e_s2_q {
6988 16         33 my($ope,$delimiter,$end_delimiter,$string) = @_;
6989              
6990 16         18 $slash = 'div';
6991 16         96  
6992 16 100       44 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
6993             for (my $i=0; $i <= $#char; $i++) {
6994             if (0) {
6995             }
6996 9         34  
6997             # not escape \\
6998             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6999             }
7000              
7001 0         0 # escape $ @ / and \
7002             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7003             $char[$i] = '\\' . $char[$i];
7004             }
7005 5         66 }
7006              
7007             return join '', $ope, $delimiter, @char, $end_delimiter;
7008             }
7009              
7010             #
7011             # escape regexp (s/here/and here/modifier)
7012 16     97 0 46 #
7013 97   100     733 sub e_sub {
7014             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7015 97         399 $modifier ||= '';
7016 97 50       192  
7017 97         717 $modifier =~ tr/p//d;
7018 0         0 if ($modifier =~ /([adlu])/oxms) {
7019 0 0       0 my $line = 0;
7020 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7021 0         0 if ($filename ne __FILE__) {
7022             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7023             last;
7024 0         0 }
7025             }
7026             die qq{Unsupported modifier "$1" used at line $line.\n};
7027 0 100       0 }
7028 97         580  
7029 36         50 if ($variable eq '') {
7030             $variable = '$_';
7031             $bind_operator = ' =~ ';
7032 36         50 }
7033              
7034             $slash = 'div';
7035              
7036             # P.128 Start of match (or end of previous match): \G
7037             # P.130 Advanced Use of \G with Perl
7038             # in Chapter 3: Overview of Regular Expression Features and Flavors
7039             # P.312 Iterative Matching: Scalar Context, with /g
7040             # in Chapter 7: Perl
7041             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7042              
7043             # P.181 Where You Left Off: The \G Assertion
7044             # in Chapter 5: Pattern Matching
7045             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7046              
7047             # P.220 Where You Left Off: The \G Assertion
7048             # in Chapter 5: Pattern Matching
7049 97         147 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7050 97         162  
7051             my $e_modifier = $modifier =~ tr/e//d;
7052 97         144 my $r_modifier = $modifier =~ tr/r//d;
7053 97 50       147  
7054 97         243 my $my = '';
7055 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7056 0         0 $my = $variable;
7057             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7058             $variable =~ s/ = .+ \z//oxms;
7059 0         0 }
7060 97         224  
7061             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7062             $variable_basename =~ s/ \s+ \z//oxms;
7063 97         176  
7064 97 100       254 # quote replacement string
7065 97         225 my $e_replacement = '';
7066 17         36 if ($e_modifier >= 1) {
7067             $e_replacement = e_qq('', '', '', $replacement);
7068             $e_modifier--;
7069 17 100       35 }
7070 80         204 else {
7071             if ($delimiter2 eq "'") {
7072             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7073 16         35 }
7074             else {
7075             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7076             }
7077 64         214 }
7078              
7079             my $sub = '';
7080 97 100       177  
7081 97 100       237 # with /r
7082             if ($r_modifier) {
7083             if (0) {
7084             }
7085 8         19  
7086 0 50       0 # s///gr without multibyte anchoring
7087             elsif ($modifier =~ /g/oxms) {
7088             $sub = sprintf(
7089             # 1 2 3 4 5
7090             q,
7091              
7092             $variable, # 1
7093             ($delimiter1 eq "'") ? # 2
7094             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7095             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7096             $s_matched, # 3
7097             $e_replacement, # 4
7098             '$Elatin1::re_r=CORE::eval $Elatin1::re_r; ' x $e_modifier, # 5
7099             );
7100             }
7101              
7102             # s///r
7103 4         13 else {
7104              
7105 4 50       4 my $prematch = q{$`};
7106              
7107             $sub = sprintf(
7108             # 1 2 3 4 5 6 7
7109             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin1::re_r=%s; %s"%s$Elatin1::re_r$'" } : %s>,
7110              
7111             $variable, # 1
7112             ($delimiter1 eq "'") ? # 2
7113             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7114             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7115             $s_matched, # 3
7116             $e_replacement, # 4
7117             '$Elatin1::re_r=CORE::eval $Elatin1::re_r; ' x $e_modifier, # 5
7118             $prematch, # 6
7119             $variable, # 7
7120             );
7121             }
7122 4 50       12  
7123 8         22 # $var !~ s///r doesn't make sense
7124             if ($bind_operator =~ / !~ /oxms) {
7125             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7126             }
7127             }
7128              
7129 0 100       0 # without /r
7130             else {
7131             if (0) {
7132             }
7133 89         201  
7134 0 100       0 # s///g without multibyte anchoring
    100          
7135             elsif ($modifier =~ /g/oxms) {
7136             $sub = sprintf(
7137             # 1 2 3 4 5 6 7 8
7138             q,
7139              
7140             $variable, # 1
7141             ($delimiter1 eq "'") ? # 2
7142             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7143             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7144             $s_matched, # 3
7145             $e_replacement, # 4
7146             '$Elatin1::re_r=CORE::eval $Elatin1::re_r; ' x $e_modifier, # 5
7147             $variable, # 6
7148             $variable, # 7
7149             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7150             );
7151             }
7152              
7153             # s///
7154 22         84 else {
7155              
7156 67 100       121 my $prematch = q{$`};
    100          
7157              
7158             $sub = sprintf(
7159              
7160             ($bind_operator =~ / =~ /oxms) ?
7161              
7162             # 1 2 3 4 5 6 7 8
7163             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin1::re_r=%s; %s%s="%s$Elatin1::re_r$'"; 1 } : undef> :
7164              
7165             # 1 2 3 4 5 6 7 8
7166             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin1::re_r=%s; %s%s="%s$Elatin1::re_r$'"; undef }>,
7167              
7168             $variable, # 1
7169             $bind_operator, # 2
7170             ($delimiter1 eq "'") ? # 3
7171             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7172             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7173             $s_matched, # 4
7174             $e_replacement, # 5
7175             '$Elatin1::re_r=CORE::eval $Elatin1::re_r; ' x $e_modifier, # 6
7176             $variable, # 7
7177             $prematch, # 8
7178             );
7179             }
7180             }
7181 67 50       349  
7182 97         2054 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7183             if ($my ne '') {
7184             $sub = "($my, $sub)[1]";
7185             }
7186 0         0  
7187 97         143 # clear s/// variable
7188             $sub_variable = '';
7189 97         135 $bind_operator = '';
7190              
7191             return $sub;
7192             }
7193              
7194             #
7195             # escape regexp of split qr//
7196 97     74 0 665 #
7197 74   100     344 sub e_split {
7198             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7199 74         411 $modifier ||= '';
7200 74 50       131  
7201 74         175 $modifier =~ tr/p//d;
7202 0         0 if ($modifier =~ /([adlu])/oxms) {
7203 0 0       0 my $line = 0;
7204 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7205 0         0 if ($filename ne __FILE__) {
7206             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7207             last;
7208 0         0 }
7209             }
7210             die qq{Unsupported modifier "$1" used at line $line.\n};
7211 0         0 }
7212              
7213             $slash = 'div';
7214 74 50       135  
7215 74         274 # /b /B modifier
7216             if ($modifier =~ tr/bB//d) {
7217             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7218 0 50       0 }
7219 74         191  
7220             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7221             my $metachar = qr/[\@\\|[\]{^]/oxms;
7222 74         273  
7223             # split regexp
7224             my @char = $string =~ /\G((?>
7225             [^\\\$\@\[\(] |
7226             \\x (?>[0-9A-Fa-f]{1,2}) |
7227             \\ (?>[0-7]{2,3}) |
7228             \\c [\x40-\x5F] |
7229             \\x\{ (?>[0-9A-Fa-f]+) \} |
7230             \\o\{ (?>[0-7]+) \} |
7231             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7232             \\ $q_char |
7233             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7234             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7235             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7236             [\$\@] $qq_variable |
7237             \$ (?>\s* [0-9]+) |
7238             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7239             \$ \$ (?![\w\{]) |
7240             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7241             \[\^ |
7242             \[\: (?>[a-z]+) :\] |
7243             \[\:\^ (?>[a-z]+) :\] |
7244             \(\? |
7245             $q_char
7246 74         9538 ))/oxmsg;
7247 74         253  
7248 74         121 my $left_e = 0;
7249             my $right_e = 0;
7250             for (my $i=0; $i <= $#char; $i++) {
7251 74 50 33     355  
    50 33        
    100          
    100          
    50          
    50          
7252 249         1345 # "\L\u" --> "\u\L"
7253             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7254             @char[$i,$i+1] = @char[$i+1,$i];
7255             }
7256              
7257 0         0 # "\U\l" --> "\l\U"
7258             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7259             @char[$i,$i+1] = @char[$i+1,$i];
7260             }
7261              
7262 0         0 # octal escape sequence
7263             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7264             $char[$i] = Elatin1::octchr($1);
7265             }
7266              
7267 1         6 # hexadecimal escape sequence
7268             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7269             $char[$i] = Elatin1::hexchr($1);
7270             }
7271              
7272             # \b{...} --> b\{...}
7273             # \B{...} --> B\{...}
7274             # \N{CHARNAME} --> N\{CHARNAME}
7275             # \p{PROPERTY} --> p\{PROPERTY}
7276 1         2 # \P{PROPERTY} --> P\{PROPERTY}
7277             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7278             $char[$i] = $1 . '\\' . $2;
7279             }
7280              
7281 0         0 # \p, \P, \X --> p, P, X
7282             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7283             $char[$i] = $1;
7284 0 50 100     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          
7285              
7286             if (0) {
7287             }
7288 249         888  
7289 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7290 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7291             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)) {
7292             $char[$i] .= join '', splice @char, $i+1, 3;
7293 0         0 }
7294             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)) {
7295             $char[$i] .= join '', splice @char, $i+1, 2;
7296 0         0 }
7297             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)) {
7298             $char[$i] .= join '', splice @char, $i+1, 1;
7299             }
7300             }
7301              
7302 0         0 # open character class [...]
7303 3 50       5 elsif ($char[$i] eq '[') {
7304 3         8 my $left = $i;
7305             if ($char[$i+1] eq ']') {
7306 0         0 $i++;
7307 3 50       3 }
7308 7         12 while (1) {
7309             if (++$i > $#char) {
7310 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7311 7         13 }
7312             if ($char[$i] eq ']') {
7313             my $right = $i;
7314 3 50       3  
7315 3         13 # [...]
  0         0  
7316             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7317             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);
7318 0         0 }
7319             else {
7320             splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
7321 3         10 }
7322 3         4  
7323             $i = $left;
7324             last;
7325             }
7326             }
7327             }
7328              
7329 3         7 # open character class [^...]
7330 0 0       0 elsif ($char[$i] eq '[^') {
7331 0         0 my $left = $i;
7332             if ($char[$i+1] eq ']') {
7333 0         0 $i++;
7334 0 0       0 }
7335 0         0 while (1) {
7336             if (++$i > $#char) {
7337 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7338 0         0 }
7339             if ($char[$i] eq ']') {
7340             my $right = $i;
7341 0 0       0  
7342 0         0 # [^...]
  0         0  
7343             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7344             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);
7345 0         0 }
7346             else {
7347             splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7348 0         0 }
7349 0         0  
7350             $i = $left;
7351             last;
7352             }
7353             }
7354             }
7355              
7356 0         0 # rewrite character class or escape character
7357             elsif (my $char = character_class($char[$i],$modifier)) {
7358             $char[$i] = $char;
7359             }
7360              
7361             # P.794 29.2.161. split
7362             # in Chapter 29: Functions
7363             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7364              
7365             # P.951 split
7366             # in Chapter 27: Functions
7367             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7368              
7369             # said "The //m modifier is assumed when you split on the pattern /^/",
7370             # but perl5.008 is not so. Therefore, this software adds //m.
7371             # (and so on)
7372              
7373 1         3 # split(m/^/) --> split(m/^/m)
7374             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7375             $modifier .= 'm';
7376             }
7377              
7378 7 0       24 # /i modifier
7379 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
7380             if (CORE::length(Elatin1::fc($char[$i])) == 1) {
7381             $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
7382 0         0 }
7383             else {
7384             $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
7385             }
7386             }
7387              
7388 0 0       0 # \u \l \U \L \F \Q \E
7389 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7390             if ($right_e < $left_e) {
7391             $char[$i] = '\\' . $char[$i];
7392             }
7393 0         0 }
7394 0         0 elsif ($char[$i] eq '\u') {
7395             $char[$i] = '@{[Elatin1::ucfirst qq<';
7396             $left_e++;
7397 0         0 }
7398 0         0 elsif ($char[$i] eq '\l') {
7399             $char[$i] = '@{[Elatin1::lcfirst qq<';
7400             $left_e++;
7401 0         0 }
7402 0         0 elsif ($char[$i] eq '\U') {
7403             $char[$i] = '@{[Elatin1::uc qq<';
7404             $left_e++;
7405 0         0 }
7406 0         0 elsif ($char[$i] eq '\L') {
7407             $char[$i] = '@{[Elatin1::lc qq<';
7408             $left_e++;
7409 0         0 }
7410 0         0 elsif ($char[$i] eq '\F') {
7411             $char[$i] = '@{[Elatin1::fc qq<';
7412             $left_e++;
7413 0         0 }
7414 0         0 elsif ($char[$i] eq '\Q') {
7415             $char[$i] = '@{[CORE::quotemeta qq<';
7416             $left_e++;
7417 0 0       0 }
7418 0         0 elsif ($char[$i] eq '\E') {
7419 0         0 if ($right_e < $left_e) {
7420             $char[$i] = '>]}';
7421             $right_e++;
7422 0         0 }
7423             else {
7424             $char[$i] = '';
7425             }
7426 0         0 }
7427 0 0       0 elsif ($char[$i] eq '\Q') {
7428 0         0 while (1) {
7429             if (++$i > $#char) {
7430 0 0       0 last;
7431 0         0 }
7432             if ($char[$i] eq '\E') {
7433             last;
7434             }
7435             }
7436             }
7437             elsif ($char[$i] eq '\E') {
7438             }
7439              
7440 0 0       0 # $0 --> $0
7441 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7442             if ($ignorecase) {
7443             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7444             }
7445 0 0       0 }
7446 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7447             if ($ignorecase) {
7448             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7449             }
7450             }
7451              
7452             # $$ --> $$
7453             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7454             }
7455              
7456             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7457 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7458 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7459 0         0 $char[$i] = e_capture($1);
7460             if ($ignorecase) {
7461             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7462             }
7463 0         0 }
7464 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7465 0         0 $char[$i] = e_capture($1);
7466             if ($ignorecase) {
7467             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7468             }
7469             }
7470              
7471 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7472 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7473 0         0 $char[$i] = e_capture($1.'->'.$2);
7474             if ($ignorecase) {
7475             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7476             }
7477             }
7478              
7479 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7480 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7481 0         0 $char[$i] = e_capture($1.'->'.$2);
7482             if ($ignorecase) {
7483             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7484             }
7485             }
7486              
7487 0         0 # $$foo
7488 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7489 0         0 $char[$i] = e_capture($1);
7490             if ($ignorecase) {
7491             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7492             }
7493             }
7494              
7495 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin1::PREMATCH()
7496 12         36 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7497             if ($ignorecase) {
7498             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::PREMATCH())]}';
7499 0         0 }
7500             else {
7501             $char[$i] = '@{[Elatin1::PREMATCH()]}';
7502             }
7503             }
7504              
7505 12 50       50 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin1::MATCH()
7506 12         33 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7507             if ($ignorecase) {
7508             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::MATCH())]}';
7509 0         0 }
7510             else {
7511             $char[$i] = '@{[Elatin1::MATCH()]}';
7512             }
7513             }
7514              
7515 12 50       56 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin1::POSTMATCH()
7516 9         24 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7517             if ($ignorecase) {
7518             $char[$i] = '@{[Elatin1::ignorecase(Elatin1::POSTMATCH())]}';
7519 0         0 }
7520             else {
7521             $char[$i] = '@{[Elatin1::POSTMATCH()]}';
7522             }
7523             }
7524              
7525 9 0       40 # ${ foo }
7526 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7527             if ($ignorecase) {
7528             $char[$i] = '@{[Elatin1::ignorecase(' . $1 . ')]}';
7529             }
7530             }
7531              
7532 0         0 # ${ ... }
7533 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7534 0         0 $char[$i] = e_capture($1);
7535             if ($ignorecase) {
7536             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7537             }
7538             }
7539              
7540 0         0 # $scalar or @array
7541 3 50       9 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7542 3         21 $char[$i] = e_string($char[$i]);
7543             if ($ignorecase) {
7544             $char[$i] = '@{[Elatin1::ignorecase(' . $char[$i] . ')]}';
7545             }
7546             }
7547              
7548 0 50       0 # quote character before ? + * {
7549             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7550             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7551 1         6 }
7552             else {
7553             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7554             }
7555             }
7556             }
7557 0         0  
7558 74 50       846 # make regexp string
7559 74         343 $modifier =~ tr/i//d;
7560             if ($left_e > $right_e) {
7561 0         0 return join '', 'Elatin1::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7562             }
7563             return join '', 'Elatin1::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7564             }
7565              
7566             #
7567             # escape regexp of split qr''
7568 74     0 0 725 #
7569 0   0       sub e_split_q {
7570             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7571 0           $modifier ||= '';
7572 0 0          
7573 0           $modifier =~ tr/p//d;
7574 0           if ($modifier =~ /([adlu])/oxms) {
7575 0 0         my $line = 0;
7576 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7577 0           if ($filename ne __FILE__) {
7578             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7579             last;
7580 0           }
7581             }
7582             die qq{Unsupported modifier "$1" used at line $line.\n};
7583 0           }
7584              
7585             $slash = 'div';
7586 0 0          
7587 0           # /b /B modifier
7588             if ($modifier =~ tr/bB//d) {
7589             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7590 0 0         }
7591              
7592             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7593 0            
7594             # split regexp
7595             my @char = $string =~ /\G((?>
7596             [^\\\[] |
7597             [\x00-\xFF] |
7598             \[\^ |
7599             \[\: (?>[a-z]+) \:\] |
7600             \[\:\^ (?>[a-z]+) \:\] |
7601             \\ (?:$q_char) |
7602             (?:$q_char)
7603             ))/oxmsg;
7604 0            
7605 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7606             for (my $i=0; $i <= $#char; $i++) {
7607             if (0) {
7608             }
7609 0            
7610 0           # open character class [...]
7611 0 0         elsif ($char[$i] eq '[') {
7612 0           my $left = $i;
7613             if ($char[$i+1] eq ']') {
7614 0           $i++;
7615 0 0         }
7616 0           while (1) {
7617             if (++$i > $#char) {
7618 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7619 0           }
7620             if ($char[$i] eq ']') {
7621             my $right = $i;
7622 0            
7623             # [...]
7624 0           splice @char, $left, $right-$left+1, Elatin1::charlist_qr(@char[$left+1..$right-1], $modifier);
7625 0            
7626             $i = $left;
7627             last;
7628             }
7629             }
7630             }
7631              
7632 0           # open character class [^...]
7633 0 0         elsif ($char[$i] eq '[^') {
7634 0           my $left = $i;
7635             if ($char[$i+1] eq ']') {
7636 0           $i++;
7637 0 0         }
7638 0           while (1) {
7639             if (++$i > $#char) {
7640 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7641 0           }
7642             if ($char[$i] eq ']') {
7643             my $right = $i;
7644 0            
7645             # [^...]
7646 0           splice @char, $left, $right-$left+1, Elatin1::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7647 0            
7648             $i = $left;
7649             last;
7650             }
7651             }
7652             }
7653              
7654 0           # rewrite character class or escape character
7655             elsif (my $char = character_class($char[$i],$modifier)) {
7656             $char[$i] = $char;
7657             }
7658              
7659 0           # split(m/^/) --> split(m/^/m)
7660             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7661             $modifier .= 'm';
7662             }
7663              
7664 0 0         # /i modifier
7665 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin1::uc($char[$i]) ne Elatin1::fc($char[$i]))) {
7666             if (CORE::length(Elatin1::fc($char[$i])) == 1) {
7667             $char[$i] = '[' . Elatin1::uc($char[$i]) . Elatin1::fc($char[$i]) . ']';
7668 0           }
7669             else {
7670             $char[$i] = '(?:' . Elatin1::uc($char[$i]) . '|' . Elatin1::fc($char[$i]) . ')';
7671             }
7672             }
7673              
7674 0 0         # quote character before ? + * {
7675             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7676             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7677 0           }
7678             else {
7679             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7680             }
7681             }
7682 0           }
7683 0            
7684             $modifier =~ tr/i//d;
7685             return join '', 'Elatin1::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7686             }
7687              
7688             #
7689             # instead of Carp::carp
7690 0     0 0   #
7691 0           sub carp {
7692             my($package,$filename,$line) = caller(1);
7693             print STDERR "@_ at $filename line $line.\n";
7694             }
7695              
7696             #
7697             # instead of Carp::croak
7698 0     0 0   #
7699 0           sub croak {
7700 0           my($package,$filename,$line) = caller(1);
7701             print STDERR "@_ at $filename line $line.\n";
7702             die "\n";
7703             }
7704              
7705             #
7706             # instead of Carp::cluck
7707 0     0 0   #
7708 0           sub cluck {
7709 0           my $i = 0;
7710 0           my @cluck = ();
7711 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7712             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7713 0           $i++;
7714 0           }
7715 0           print STDERR CORE::reverse @cluck;
7716             print STDERR "\n";
7717             print STDERR @_;
7718             }
7719              
7720             #
7721             # instead of Carp::confess
7722 0     0 0   #
7723 0           sub confess {
7724 0           my $i = 0;
7725 0           my @confess = ();
7726 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7727             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7728 0           $i++;
7729 0           }
7730 0           print STDERR CORE::reverse @confess;
7731 0           print STDERR "\n";
7732             print STDERR @_;
7733             die "\n";
7734             }
7735              
7736             1;
7737              
7738             __END__