File Coverage

blib/lib/Elatin10.pm
Criterion Covered Total %
statement 905 3194 28.3
branch 968 2740 35.3
condition 98 355 27.6
subroutine 52 110 47.2
pod 7 74 9.4
total 2030 6473 31.3


line stmt bran cond sub pod time code
1             package Elatin10;
2 204     204   1379 use strict;
  204         495  
  204         7579  
3             ######################################################################
4             #
5             # Elatin10 - Run-time routines for Latin10.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin10/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   3025 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         580  
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   967 use vars qw($VERSION);
  204         392  
  204         33314  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1581 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         399 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         27048 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   13989 CORE::eval q{
  204     204   1160  
  204     68   393  
  204         24226  
  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       89992 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 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     0 0 0 my($name) = @_;
73              
74 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
75 0         0 return $name;
76             }
77             elsif (Elatin10::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Elatin10::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 0         0 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 0   0 0 0 if (defined $_[1]) {
112 204     204   1395 no strict qw(refs);
  204         370  
  204         14646  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1282 no strict qw(refs);
  204     0   364  
  204         42296  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x00-\xFF]};
148 204     204   1638 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         359  
  204         14686  
149 204     204   1289 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         403  
  204         398123  
150              
151             #
152             # Latin-10 character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # Latin-10 case conversion
158             #
159             my %lc = ();
160             @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)} =
161             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
162             my %uc = ();
163             @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)} =
164             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
165             my %fc = ();
166             @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)} =
167             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);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Elatin10 \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177              
178             %lc = (%lc,
179             "\xA1" => "\xA2", # LATIN LETTER A WITH OGONEK
180             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
181             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
182             "\xAA" => "\xBA", # LATIN LETTER S WITH COMMA BELOW
183             "\xAC" => "\xAE", # LATIN LETTER Z WITH ACUTE
184             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
185             "\xB2" => "\xB9", # LATIN LETTER C WITH CARON
186             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
187             "\xBC" => "\xBD", # LATIN LIGATURE OE
188             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
189             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
190             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
191             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
192             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
193             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
194             "\xC5" => "\xE5", # LATIN LETTER C WITH ACUTE
195             "\xC6" => "\xE6", # LATIN LETTER AE
196             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
197             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
198             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
199             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
200             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
201             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
202             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
203             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
204             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
205             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
206             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
207             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
208             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
209             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
210             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
211             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
212             "\xD7" => "\xF7", # LATIN LETTER S WITH ACUTE
213             "\xD8" => "\xF8", # LATIN LETTER U WITH DOUBLE ACUTE
214             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
215             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
216             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
217             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
218             "\xDD" => "\xFD", # LATIN LETTER E WITH OGONEK
219             "\xDE" => "\xFE", # LATIN LETTER T WITH COMMA BELOW
220             );
221              
222             %uc = (%uc,
223             "\xA2" => "\xA1", # LATIN LETTER A WITH OGONEK
224             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
225             "\xAE" => "\xAC", # LATIN LETTER Z WITH ACUTE
226             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
227             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
228             "\xB9" => "\xB2", # LATIN LETTER C WITH CARON
229             "\xBA" => "\xAA", # LATIN LETTER S WITH COMMA BELOW
230             "\xBD" => "\xBC", # LATIN LIGATURE OE
231             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
232             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
233             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
234             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
235             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
236             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
237             "\xE5" => "\xC5", # LATIN LETTER C WITH ACUTE
238             "\xE6" => "\xC6", # LATIN LETTER AE
239             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
240             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
241             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
242             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
243             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
244             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
245             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
246             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
247             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
248             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
249             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
250             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
251             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
252             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
253             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
254             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
255             "\xF7" => "\xD7", # LATIN LETTER S WITH ACUTE
256             "\xF8" => "\xD8", # LATIN LETTER U WITH DOUBLE ACUTE
257             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
258             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
259             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
260             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
261             "\xFD" => "\xDD", # LATIN LETTER E WITH OGONEK
262             "\xFE" => "\xDE", # LATIN LETTER T WITH COMMA BELOW
263             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
264             );
265              
266             %fc = (%fc,
267             "\xA1" => "\xA2", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
268             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
269             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
270             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH COMMA BELOW --> LATIN SMALL LETTER S WITH COMMA BELOW
271             "\xAC" => "\xAE", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
272             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
273             "\xB2" => "\xB9", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
274             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
275             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
276             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
277             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
278             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
279             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
280             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
281             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
282             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
283             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
284             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
285             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
286             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
287             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
288             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
289             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
290             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
291             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
292             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
293             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
294             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
295             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
296             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
297             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
298             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
299             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
300             "\xD7" => "\xF7", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
301             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
302             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
303             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
304             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
305             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
306             "\xDD" => "\xFD", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
307             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH COMMA BELOW --> LATIN SMALL LETTER T WITH COMMA BELOW
308             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
309             );
310             }
311              
312             else {
313             croak "Don't know my package name '@{[__PACKAGE__]}'";
314             }
315              
316             #
317             # @ARGV wildcard globbing
318             #
319             sub import {
320              
321 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
322 0         0 my @argv = ();
323 0         0 for (@ARGV) {
324              
325             # has space
326 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
327 0 0       0 if (my @glob = Elatin10::glob(qq{"$_"})) {
328 0         0 push @argv, @glob;
329             }
330             else {
331 0         0 push @argv, $_;
332             }
333             }
334              
335             # has wildcard metachar
336             elsif (/\A (?:$q_char)*? [*?] /oxms) {
337 0 0       0 if (my @glob = Elatin10::glob($_)) {
338 0         0 push @argv, @glob;
339             }
340             else {
341 0         0 push @argv, $_;
342             }
343             }
344              
345             # no wildcard globbing
346             else {
347 0         0 push @argv, $_;
348             }
349             }
350 0         0 @ARGV = @argv;
351             }
352              
353 0         0 *Char::ord = \&Latin10::ord;
354 0         0 *Char::ord_ = \&Latin10::ord_;
355 0         0 *Char::reverse = \&Latin10::reverse;
356 0         0 *Char::getc = \&Latin10::getc;
357 0         0 *Char::length = \&Latin10::length;
358 0         0 *Char::substr = \&Latin10::substr;
359 0         0 *Char::index = \&Latin10::index;
360 0         0 *Char::rindex = \&Latin10::rindex;
361 0         0 *Char::eval = \&Latin10::eval;
362 0         0 *Char::escape = \&Latin10::escape;
363 0         0 *Char::escape_token = \&Latin10::escape_token;
364 0         0 *Char::escape_script = \&Latin10::escape_script;
365             }
366              
367             # P.230 Care with Prototypes
368             # in Chapter 6: Subroutines
369             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
370             #
371             # If you aren't careful, you can get yourself into trouble with prototypes.
372             # But if you are careful, you can do a lot of neat things with them. This is
373             # all very powerful, of course, and should only be used in moderation to make
374             # the world a better place.
375              
376             # P.332 Care with Prototypes
377             # in Chapter 7: Subroutines
378             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
379             #
380             # If you aren't careful, you can get yourself into trouble with prototypes.
381             # But if you are careful, you can do a lot of neat things with them. This is
382             # all very powerful, of course, and should only be used in moderation to make
383             # the world a better place.
384              
385             #
386             # Prototypes of subroutines
387             #
388       0     sub unimport {}
389             sub Elatin10::split(;$$$);
390             sub Elatin10::tr($$$$;$);
391             sub Elatin10::chop(@);
392             sub Elatin10::index($$;$);
393             sub Elatin10::rindex($$;$);
394             sub Elatin10::lcfirst(@);
395             sub Elatin10::lcfirst_();
396             sub Elatin10::lc(@);
397             sub Elatin10::lc_();
398             sub Elatin10::ucfirst(@);
399             sub Elatin10::ucfirst_();
400             sub Elatin10::uc(@);
401             sub Elatin10::uc_();
402             sub Elatin10::fc(@);
403             sub Elatin10::fc_();
404             sub Elatin10::ignorecase;
405             sub Elatin10::classic_character_class;
406             sub Elatin10::capture;
407             sub Elatin10::chr(;$);
408             sub Elatin10::chr_();
409             sub Elatin10::glob($);
410             sub Elatin10::glob_();
411              
412             sub Latin10::ord(;$);
413             sub Latin10::ord_();
414             sub Latin10::reverse(@);
415             sub Latin10::getc(;*@);
416             sub Latin10::length(;$);
417             sub Latin10::substr($$;$$);
418             sub Latin10::index($$;$);
419             sub Latin10::rindex($$;$);
420             sub Latin10::escape(;$);
421              
422             #
423             # Regexp work
424             #
425 204         17084 use vars qw(
426             $re_a
427             $re_t
428             $re_n
429             $re_r
430 204     204   1449 );
  204         376  
431              
432             #
433             # Character class
434             #
435 204         1995584 use vars qw(
436             $dot
437             $dot_s
438             $eD
439             $eS
440             $eW
441             $eH
442             $eV
443             $eR
444             $eN
445             $not_alnum
446             $not_alpha
447             $not_ascii
448             $not_blank
449             $not_cntrl
450             $not_digit
451             $not_graph
452             $not_lower
453             $not_lower_i
454             $not_print
455             $not_punct
456             $not_space
457             $not_upper
458             $not_upper_i
459             $not_word
460             $not_xdigit
461             $eb
462             $eB
463 204     204   1180 );
  204         355  
464              
465             ${Elatin10::dot} = qr{(?>[^\x0A])};
466             ${Elatin10::dot_s} = qr{(?>[\x00-\xFF])};
467             ${Elatin10::eD} = qr{(?>[^0-9])};
468              
469             # Vertical tabs are now whitespace
470             # \s in a regex now matches a vertical tab in all circumstances.
471             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
472             # ${Elatin10::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
473             # ${Elatin10::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
474             ${Elatin10::eS} = qr{(?>[^\s])};
475              
476             ${Elatin10::eW} = qr{(?>[^0-9A-Z_a-z])};
477             ${Elatin10::eH} = qr{(?>[^\x09\x20])};
478             ${Elatin10::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
479             ${Elatin10::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
480             ${Elatin10::eN} = qr{(?>[^\x0A])};
481             ${Elatin10::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
482             ${Elatin10::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
483             ${Elatin10::not_ascii} = qr{(?>[^\x00-\x7F])};
484             ${Elatin10::not_blank} = qr{(?>[^\x09\x20])};
485             ${Elatin10::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
486             ${Elatin10::not_digit} = qr{(?>[^\x30-\x39])};
487             ${Elatin10::not_graph} = qr{(?>[^\x21-\x7F])};
488             ${Elatin10::not_lower} = qr{(?>[^\x61-\x7A])};
489             ${Elatin10::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
490             # ${Elatin10::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
491             ${Elatin10::not_print} = qr{(?>[^\x20-\x7F])};
492             ${Elatin10::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
493             ${Elatin10::not_space} = qr{(?>[^\s\x0B])};
494             ${Elatin10::not_upper} = qr{(?>[^\x41-\x5A])};
495             ${Elatin10::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
496             # ${Elatin10::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
497             ${Elatin10::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
498             ${Elatin10::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
499             ${Elatin10::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))};
500             ${Elatin10::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]))};
501              
502             # avoid: Name "Elatin10::foo" used only once: possible typo at here.
503             ${Elatin10::dot} = ${Elatin10::dot};
504             ${Elatin10::dot_s} = ${Elatin10::dot_s};
505             ${Elatin10::eD} = ${Elatin10::eD};
506             ${Elatin10::eS} = ${Elatin10::eS};
507             ${Elatin10::eW} = ${Elatin10::eW};
508             ${Elatin10::eH} = ${Elatin10::eH};
509             ${Elatin10::eV} = ${Elatin10::eV};
510             ${Elatin10::eR} = ${Elatin10::eR};
511             ${Elatin10::eN} = ${Elatin10::eN};
512             ${Elatin10::not_alnum} = ${Elatin10::not_alnum};
513             ${Elatin10::not_alpha} = ${Elatin10::not_alpha};
514             ${Elatin10::not_ascii} = ${Elatin10::not_ascii};
515             ${Elatin10::not_blank} = ${Elatin10::not_blank};
516             ${Elatin10::not_cntrl} = ${Elatin10::not_cntrl};
517             ${Elatin10::not_digit} = ${Elatin10::not_digit};
518             ${Elatin10::not_graph} = ${Elatin10::not_graph};
519             ${Elatin10::not_lower} = ${Elatin10::not_lower};
520             ${Elatin10::not_lower_i} = ${Elatin10::not_lower_i};
521             ${Elatin10::not_print} = ${Elatin10::not_print};
522             ${Elatin10::not_punct} = ${Elatin10::not_punct};
523             ${Elatin10::not_space} = ${Elatin10::not_space};
524             ${Elatin10::not_upper} = ${Elatin10::not_upper};
525             ${Elatin10::not_upper_i} = ${Elatin10::not_upper_i};
526             ${Elatin10::not_word} = ${Elatin10::not_word};
527             ${Elatin10::not_xdigit} = ${Elatin10::not_xdigit};
528             ${Elatin10::eb} = ${Elatin10::eb};
529             ${Elatin10::eB} = ${Elatin10::eB};
530              
531             #
532             # Latin-10 split
533             #
534             sub Elatin10::split(;$$$) {
535              
536             # P.794 29.2.161. split
537             # in Chapter 29: Functions
538             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
539              
540             # P.951 split
541             # in Chapter 27: Functions
542             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
543              
544 0     0 0 0 my $pattern = $_[0];
545 0         0 my $string = $_[1];
546 0         0 my $limit = $_[2];
547              
548             # if $pattern is also omitted or is the literal space, " "
549 0 0       0 if (not defined $pattern) {
550 0         0 $pattern = ' ';
551             }
552              
553             # if $string is omitted, the function splits the $_ string
554 0 0       0 if (not defined $string) {
555 0 0       0 if (defined $_) {
556 0         0 $string = $_;
557             }
558             else {
559 0         0 $string = '';
560             }
561             }
562              
563 0         0 my @split = ();
564              
565             # when string is empty
566 0 0       0 if ($string eq '') {
    0          
567              
568             # resulting list value in list context
569 0 0       0 if (wantarray) {
570 0         0 return @split;
571             }
572              
573             # count of substrings in scalar context
574             else {
575 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
576 0         0 @_ = @split;
577 0         0 return scalar @_;
578             }
579             }
580              
581             # split's first argument is more consistently interpreted
582             #
583             # After some changes earlier in v5.17, split's behavior has been simplified:
584             # if the PATTERN argument evaluates to a string containing one space, it is
585             # treated the way that a literal string containing one space once was.
586             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
587              
588             # if $pattern is also omitted or is the literal space, " ", the function splits
589             # on whitespace, /\s+/, after skipping any leading whitespace
590             # (and so on)
591              
592             elsif ($pattern eq ' ') {
593 0 0       0 if (not defined $limit) {
594 0         0 return CORE::split(' ', $string);
595             }
596             else {
597 0         0 return CORE::split(' ', $string, $limit);
598             }
599             }
600              
601             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
602 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
603              
604             # a pattern capable of matching either the null string or something longer than the
605             # null string will split the value of $string into separate characters wherever it
606             # matches the null string between characters
607             # (and so on)
608              
609 0 0       0 if ('' =~ / \A $pattern \z /xms) {
610 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
611 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
612              
613             # P.1024 Appendix W.10 Multibyte Processing
614             # of ISBN 1-56592-224-7 CJKV Information Processing
615             # (and so on)
616              
617             # the //m modifier is assumed when you split on the pattern /^/
618             # (and so on)
619              
620             # V
621 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
622              
623             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
624             # is included in the resulting list, interspersed with the fields that are ordinarily returned
625             # (and so on)
626              
627 0         0 local $@;
628 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
629 0         0 push @split, CORE::eval('$' . $digit);
630             }
631             }
632             }
633              
634             else {
635 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
636              
637             # V
638 0         0 while ($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             elsif ($limit > 0) {
648 0 0       0 if ('' =~ / \A $pattern \z /xms) {
649 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
650 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
651              
652             # V
653 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
654 0         0 local $@;
655 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
656 0         0 push @split, CORE::eval('$' . $digit);
657             }
658             }
659             }
660             }
661             else {
662 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
663 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
664              
665             # V
666 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
667 0         0 local $@;
668 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
669 0         0 push @split, CORE::eval('$' . $digit);
670             }
671             }
672             }
673             }
674             }
675              
676 0 0       0 if (CORE::length($string) > 0) {
677 0         0 push @split, $string;
678             }
679              
680             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
681 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
682 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
683 0         0 pop @split;
684             }
685             }
686              
687             # resulting list value in list context
688 0 0       0 if (wantarray) {
689 0         0 return @split;
690             }
691              
692             # count of substrings in scalar context
693             else {
694 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
695 0         0 @_ = @split;
696 0         0 return scalar @_;
697             }
698             }
699              
700             #
701             # get last subexpression offsets
702             #
703             sub _last_subexpression_offsets {
704 0     0   0 my $pattern = $_[0];
705              
706             # remove comment
707 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
708              
709 0         0 my $modifier = '';
710 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
711 0         0 $modifier = $1;
712 0         0 $modifier =~ s/-[A-Za-z]*//;
713             }
714              
715             # with /x modifier
716 0         0 my @char = ();
717 0 0       0 if ($modifier =~ /x/oxms) {
718 0         0 @char = $pattern =~ /\G((?>
719             [^\\\#\[\(] |
720             \\ $q_char |
721             \# (?>[^\n]*) $ |
722             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
723             \(\? |
724             $q_char
725             ))/oxmsg;
726             }
727              
728             # without /x modifier
729             else {
730 0         0 @char = $pattern =~ /\G((?>
731             [^\\\[\(] |
732             \\ $q_char |
733             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
734             \(\? |
735             $q_char
736             ))/oxmsg;
737             }
738              
739 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
740             }
741              
742             #
743             # Latin-10 transliteration (tr///)
744             #
745             sub Elatin10::tr($$$$;$) {
746              
747 0     0 0 0 my $bind_operator = $_[1];
748 0         0 my $searchlist = $_[2];
749 0         0 my $replacementlist = $_[3];
750 0   0     0 my $modifier = $_[4] || '';
751              
752 0 0       0 if ($modifier =~ /r/oxms) {
753 0 0       0 if ($bind_operator =~ / !~ /oxms) {
754 0         0 croak "Using !~ with tr///r doesn't make sense";
755             }
756             }
757              
758 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
759 0         0 my @searchlist = _charlist_tr($searchlist);
760 0         0 my @replacementlist = _charlist_tr($replacementlist);
761              
762 0         0 my %tr = ();
763 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
764 0 0       0 if (not exists $tr{$searchlist[$i]}) {
765 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
766 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
767             }
768             elsif ($modifier =~ /d/oxms) {
769 0         0 $tr{$searchlist[$i]} = '';
770             }
771             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
772 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
773             }
774             else {
775 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
776             }
777             }
778             }
779              
780 0         0 my $tr = 0;
781 0         0 my $replaced = '';
782 0 0       0 if ($modifier =~ /c/oxms) {
783 0         0 while (defined(my $char = shift @char)) {
784 0 0       0 if (not exists $tr{$char}) {
785 0 0       0 if (defined $replacementlist[0]) {
786 0         0 $replaced .= $replacementlist[0];
787             }
788 0         0 $tr++;
789 0 0       0 if ($modifier =~ /s/oxms) {
790 0   0     0 while (@char and (not exists $tr{$char[0]})) {
791 0         0 shift @char;
792 0         0 $tr++;
793             }
794             }
795             }
796             else {
797 0         0 $replaced .= $char;
798             }
799             }
800             }
801             else {
802 0         0 while (defined(my $char = shift @char)) {
803 0 0       0 if (exists $tr{$char}) {
804 0         0 $replaced .= $tr{$char};
805 0         0 $tr++;
806 0 0       0 if ($modifier =~ /s/oxms) {
807 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
808 0         0 shift @char;
809 0         0 $tr++;
810             }
811             }
812             }
813             else {
814 0         0 $replaced .= $char;
815             }
816             }
817             }
818              
819 0 0       0 if ($modifier =~ /r/oxms) {
820 0         0 return $replaced;
821             }
822             else {
823 0         0 $_[0] = $replaced;
824 0 0       0 if ($bind_operator =~ / !~ /oxms) {
825 0         0 return not $tr;
826             }
827             else {
828 0         0 return $tr;
829             }
830             }
831             }
832              
833             #
834             # Latin-10 chop
835             #
836             sub Elatin10::chop(@) {
837              
838 0     0 0 0 my $chop;
839 0 0       0 if (@_ == 0) {
840 0         0 my @char = /\G (?>$q_char) /oxmsg;
841 0         0 $chop = pop @char;
842 0         0 $_ = join '', @char;
843             }
844             else {
845 0         0 for (@_) {
846 0         0 my @char = /\G (?>$q_char) /oxmsg;
847 0         0 $chop = pop @char;
848 0         0 $_ = join '', @char;
849             }
850             }
851 0         0 return $chop;
852             }
853              
854             #
855             # Latin-10 index by octet
856             #
857             sub Elatin10::index($$;$) {
858              
859 0     0 1 0 my($str,$substr,$position) = @_;
860 0   0     0 $position ||= 0;
861 0         0 my $pos = 0;
862              
863 0         0 while ($pos < CORE::length($str)) {
864 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
865 0 0       0 if ($pos >= $position) {
866 0         0 return $pos;
867             }
868             }
869 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
870 0         0 $pos += CORE::length($1);
871             }
872             else {
873 0         0 $pos += 1;
874             }
875             }
876 0         0 return -1;
877             }
878              
879             #
880             # Latin-10 reverse index
881             #
882             sub Elatin10::rindex($$;$) {
883              
884 0     0 0 0 my($str,$substr,$position) = @_;
885 0   0     0 $position ||= CORE::length($str) - 1;
886 0         0 my $pos = 0;
887 0         0 my $rindex = -1;
888              
889 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
890 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
891 0         0 $rindex = $pos;
892             }
893 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
894 0         0 $pos += CORE::length($1);
895             }
896             else {
897 0         0 $pos += 1;
898             }
899             }
900 0         0 return $rindex;
901             }
902              
903             #
904             # Latin-10 lower case first with parameter
905             #
906             sub Elatin10::lcfirst(@) {
907 0 0   0 0 0 if (@_) {
908 0         0 my $s = shift @_;
909 0 0 0     0 if (@_ and wantarray) {
910 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
911             }
912             else {
913 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
914             }
915             }
916             else {
917 0         0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
918             }
919             }
920              
921             #
922             # Latin-10 lower case first without parameter
923             #
924             sub Elatin10::lcfirst_() {
925 0     0 0 0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
926             }
927              
928             #
929             # Latin-10 lower case with parameter
930             #
931             sub Elatin10::lc(@) {
932 0 0   0 0 0 if (@_) {
933 0         0 my $s = shift @_;
934 0 0 0     0 if (@_ and wantarray) {
935 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
936             }
937             else {
938 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
939             }
940             }
941             else {
942 0         0 return Elatin10::lc_();
943             }
944             }
945              
946             #
947             # Latin-10 lower case without parameter
948             #
949             sub Elatin10::lc_() {
950 0     0 0 0 my $s = $_;
951 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
952             }
953              
954             #
955             # Latin-10 upper case first with parameter
956             #
957             sub Elatin10::ucfirst(@) {
958 0 0   0 0 0 if (@_) {
959 0         0 my $s = shift @_;
960 0 0 0     0 if (@_ and wantarray) {
961 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
962             }
963             else {
964 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
965             }
966             }
967             else {
968 0         0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
969             }
970             }
971              
972             #
973             # Latin-10 upper case first without parameter
974             #
975             sub Elatin10::ucfirst_() {
976 0     0 0 0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
977             }
978              
979             #
980             # Latin-10 upper case with parameter
981             #
982             sub Elatin10::uc(@) {
983 0 50   174 0 0 if (@_) {
984 174         264 my $s = shift @_;
985 174 50 33     220 if (@_ and wantarray) {
986 174 0       362 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
987             }
988             else {
989 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         532  
990             }
991             }
992             else {
993 174         619 return Elatin10::uc_();
994             }
995             }
996              
997             #
998             # Latin-10 upper case without parameter
999             #
1000             sub Elatin10::uc_() {
1001 0     0 0 0 my $s = $_;
1002 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1003             }
1004              
1005             #
1006             # Latin-10 fold case with parameter
1007             #
1008             sub Elatin10::fc(@) {
1009 0 50   197 0 0 if (@_) {
1010 197         279 my $s = shift @_;
1011 197 50 33     231 if (@_ and wantarray) {
1012 197 0       332 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1013             }
1014             else {
1015 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         468  
1016             }
1017             }
1018             else {
1019 197         1204 return Elatin10::fc_();
1020             }
1021             }
1022              
1023             #
1024             # Latin-10 fold case without parameter
1025             #
1026             sub Elatin10::fc_() {
1027 0     0 0 0 my $s = $_;
1028 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1029             }
1030              
1031             #
1032             # Latin-10 regexp capture
1033             #
1034             {
1035             sub Elatin10::capture {
1036 0     0 1 0 return $_[0];
1037             }
1038             }
1039              
1040             #
1041             # Latin-10 regexp ignore case modifier
1042             #
1043             sub Elatin10::ignorecase {
1044              
1045 0     0 0 0 my @string = @_;
1046 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1047              
1048             # ignore case of $scalar or @array
1049 0         0 for my $string (@string) {
1050              
1051             # split regexp
1052 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1053              
1054             # unescape character
1055 0         0 for (my $i=0; $i <= $#char; $i++) {
1056 0 0       0 next if not defined $char[$i];
1057              
1058             # open character class [...]
1059 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1060 0         0 my $left = $i;
1061              
1062             # [] make die "unmatched [] in regexp ...\n"
1063              
1064 0 0       0 if ($char[$i+1] eq ']') {
1065 0         0 $i++;
1066             }
1067              
1068 0         0 while (1) {
1069 0 0       0 if (++$i > $#char) {
1070 0         0 croak "Unmatched [] in regexp";
1071             }
1072 0 0       0 if ($char[$i] eq ']') {
1073 0         0 my $right = $i;
1074 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1075              
1076             # escape character
1077 0         0 for my $char (@charlist) {
1078 0 0       0 if (0) {
1079             }
1080              
1081 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1082 0         0 $char = '\\' . $char;
1083             }
1084             }
1085              
1086             # [...]
1087 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1088              
1089 0         0 $i = $left;
1090 0         0 last;
1091             }
1092             }
1093             }
1094              
1095             # open character class [^...]
1096             elsif ($char[$i] eq '[^') {
1097 0         0 my $left = $i;
1098              
1099             # [^] make die "unmatched [] in regexp ...\n"
1100              
1101 0 0       0 if ($char[$i+1] eq ']') {
1102 0         0 $i++;
1103             }
1104              
1105 0         0 while (1) {
1106 0 0       0 if (++$i > $#char) {
1107 0         0 croak "Unmatched [] in regexp";
1108             }
1109 0 0       0 if ($char[$i] eq ']') {
1110 0         0 my $right = $i;
1111 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1112              
1113             # escape character
1114 0         0 for my $char (@charlist) {
1115 0 0       0 if (0) {
1116             }
1117              
1118 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1119 0         0 $char = '\\' . $char;
1120             }
1121             }
1122              
1123             # [^...]
1124 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1125              
1126 0         0 $i = $left;
1127 0         0 last;
1128             }
1129             }
1130             }
1131              
1132             # rewrite classic character class or escape character
1133             elsif (my $char = classic_character_class($char[$i])) {
1134 0         0 $char[$i] = $char;
1135             }
1136              
1137             # with /i modifier
1138             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1139 0         0 my $uc = Elatin10::uc($char[$i]);
1140 0         0 my $fc = Elatin10::fc($char[$i]);
1141 0 0       0 if ($uc ne $fc) {
1142 0 0       0 if (CORE::length($fc) == 1) {
1143 0         0 $char[$i] = '[' . $uc . $fc . ']';
1144             }
1145             else {
1146 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1147             }
1148             }
1149             }
1150             }
1151              
1152             # characterize
1153 0         0 for (my $i=0; $i <= $#char; $i++) {
1154 0 0       0 next if not defined $char[$i];
1155              
1156 0 0       0 if (0) {
1157             }
1158              
1159             # quote character before ? + * {
1160 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1161 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1162 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1163             }
1164             }
1165             }
1166              
1167 0         0 $string = join '', @char;
1168             }
1169              
1170             # make regexp string
1171 0         0 return @string;
1172             }
1173              
1174             #
1175             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1176             #
1177             sub Elatin10::classic_character_class {
1178 0     1867 0 0 my($char) = @_;
1179              
1180             return {
1181             '\D' => '${Elatin10::eD}',
1182             '\S' => '${Elatin10::eS}',
1183             '\W' => '${Elatin10::eW}',
1184             '\d' => '[0-9]',
1185              
1186             # Before Perl 5.6, \s only matched the five whitespace characters
1187             # tab, newline, form-feed, carriage return, and the space character
1188             # itself, which, taken together, is the character class [\t\n\f\r ].
1189              
1190             # Vertical tabs are now whitespace
1191             # \s in a regex now matches a vertical tab in all circumstances.
1192             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1193             # \t \n \v \f \r space
1194             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1195             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1196             '\s' => '\s',
1197              
1198             '\w' => '[0-9A-Z_a-z]',
1199             '\C' => '[\x00-\xFF]',
1200             '\X' => 'X',
1201              
1202             # \h \v \H \V
1203              
1204             # P.114 Character Class Shortcuts
1205             # in Chapter 7: In the World of Regular Expressions
1206             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1207              
1208             # P.357 13.2.3 Whitespace
1209             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1210             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1211             #
1212             # 0x00009 CHARACTER TABULATION h s
1213             # 0x0000a LINE FEED (LF) vs
1214             # 0x0000b LINE TABULATION v
1215             # 0x0000c FORM FEED (FF) vs
1216             # 0x0000d CARRIAGE RETURN (CR) vs
1217             # 0x00020 SPACE h s
1218              
1219             # P.196 Table 5-9. Alphanumeric regex metasymbols
1220             # in Chapter 5. Pattern Matching
1221             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1222              
1223             # (and so on)
1224              
1225             '\H' => '${Elatin10::eH}',
1226             '\V' => '${Elatin10::eV}',
1227             '\h' => '[\x09\x20]',
1228             '\v' => '[\x0A\x0B\x0C\x0D]',
1229             '\R' => '${Elatin10::eR}',
1230              
1231             # \N
1232             #
1233             # http://perldoc.perl.org/perlre.html
1234             # Character Classes and other Special Escapes
1235             # Any character but \n (experimental). Not affected by /s modifier
1236              
1237             '\N' => '${Elatin10::eN}',
1238              
1239             # \b \B
1240              
1241             # P.180 Boundaries: The \b and \B Assertions
1242             # in Chapter 5: Pattern Matching
1243             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1244              
1245             # P.219 Boundaries: The \b and \B Assertions
1246             # in Chapter 5: Pattern Matching
1247             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1248              
1249             # \b really means (?:(?<=\w)(?!\w)|(?
1250             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1251             '\b' => '${Elatin10::eb}',
1252              
1253             # \B really means (?:(?<=\w)(?=\w)|(?
1254             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1255             '\B' => '${Elatin10::eB}',
1256              
1257 1867   100     2574 }->{$char} || '';
1258             }
1259              
1260             #
1261             # prepare Latin-10 characters per length
1262             #
1263              
1264             # 1 octet characters
1265             my @chars1 = ();
1266             sub chars1 {
1267 1867 0   0 0 70337 if (@chars1) {
1268 0         0 return @chars1;
1269             }
1270 0 0       0 if (exists $range_tr{1}) {
1271 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1272 0         0 while (my @range = splice(@ranges,0,1)) {
1273 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1274 0         0 push @chars1, pack 'C', $oct0;
1275             }
1276             }
1277             }
1278 0         0 return @chars1;
1279             }
1280              
1281             # 2 octets characters
1282             my @chars2 = ();
1283             sub chars2 {
1284 0 0   0 0 0 if (@chars2) {
1285 0         0 return @chars2;
1286             }
1287 0 0       0 if (exists $range_tr{2}) {
1288 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1289 0         0 while (my @range = splice(@ranges,0,2)) {
1290 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1291 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1292 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1293             }
1294             }
1295             }
1296             }
1297 0         0 return @chars2;
1298             }
1299              
1300             # 3 octets characters
1301             my @chars3 = ();
1302             sub chars3 {
1303 0 0   0 0 0 if (@chars3) {
1304 0         0 return @chars3;
1305             }
1306 0 0       0 if (exists $range_tr{3}) {
1307 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1308 0         0 while (my @range = splice(@ranges,0,3)) {
1309 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1310 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1311 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1312 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1313             }
1314             }
1315             }
1316             }
1317             }
1318 0         0 return @chars3;
1319             }
1320              
1321             # 4 octets characters
1322             my @chars4 = ();
1323             sub chars4 {
1324 0 0   0 0 0 if (@chars4) {
1325 0         0 return @chars4;
1326             }
1327 0 0       0 if (exists $range_tr{4}) {
1328 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1329 0         0 while (my @range = splice(@ranges,0,4)) {
1330 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1331 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1332 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1333 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1334 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1335             }
1336             }
1337             }
1338             }
1339             }
1340             }
1341 0         0 return @chars4;
1342             }
1343              
1344             #
1345             # Latin-10 open character list for tr
1346             #
1347             sub _charlist_tr {
1348              
1349 0     0   0 local $_ = shift @_;
1350              
1351             # unescape character
1352 0         0 my @char = ();
1353 0         0 while (not /\G \z/oxmsgc) {
1354 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1355 0         0 push @char, '\-';
1356             }
1357             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1358 0         0 push @char, CORE::chr(oct $1);
1359             }
1360             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1361 0         0 push @char, CORE::chr(hex $1);
1362             }
1363             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1364 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1365             }
1366             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1367             push @char, {
1368             '\0' => "\0",
1369             '\n' => "\n",
1370             '\r' => "\r",
1371             '\t' => "\t",
1372             '\f' => "\f",
1373             '\b' => "\x08", # \b means backspace in character class
1374             '\a' => "\a",
1375             '\e' => "\e",
1376 0         0 }->{$1};
1377             }
1378             elsif (/\G \\ ($q_char) /oxmsgc) {
1379 0         0 push @char, $1;
1380             }
1381             elsif (/\G ($q_char) /oxmsgc) {
1382 0         0 push @char, $1;
1383             }
1384             }
1385              
1386             # join separated multiple-octet
1387 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1388              
1389             # unescape '-'
1390 0         0 my @i = ();
1391 0         0 for my $i (0 .. $#char) {
1392 0 0       0 if ($char[$i] eq '\-') {
    0          
1393 0         0 $char[$i] = '-';
1394             }
1395             elsif ($char[$i] eq '-') {
1396 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1397 0         0 push @i, $i;
1398             }
1399             }
1400             }
1401              
1402             # open character list (reverse for splice)
1403 0         0 for my $i (CORE::reverse @i) {
1404 0         0 my @range = ();
1405              
1406             # range error
1407 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1408 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1409             }
1410              
1411             # range of multiple-octet code
1412 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1413 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1414 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1415             }
1416             elsif (CORE::length($char[$i+1]) == 2) {
1417 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1418 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1419             }
1420             elsif (CORE::length($char[$i+1]) == 3) {
1421 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1422 0         0 push @range, chars2();
1423 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1424             }
1425             elsif (CORE::length($char[$i+1]) == 4) {
1426 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1427 0         0 push @range, chars2();
1428 0         0 push @range, chars3();
1429 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1430             }
1431             else {
1432 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1433             }
1434             }
1435             elsif (CORE::length($char[$i-1]) == 2) {
1436 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1437 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1438             }
1439             elsif (CORE::length($char[$i+1]) == 3) {
1440 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1441 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1442             }
1443             elsif (CORE::length($char[$i+1]) == 4) {
1444 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1445 0         0 push @range, chars3();
1446 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1447             }
1448             else {
1449 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1450             }
1451             }
1452             elsif (CORE::length($char[$i-1]) == 3) {
1453 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1454 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1455             }
1456             elsif (CORE::length($char[$i+1]) == 4) {
1457 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1458 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1459             }
1460             else {
1461 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1462             }
1463             }
1464             elsif (CORE::length($char[$i-1]) == 4) {
1465 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1466 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1467             }
1468             else {
1469 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1470             }
1471             }
1472             else {
1473 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1474             }
1475              
1476 0         0 splice @char, $i-1, 3, @range;
1477             }
1478              
1479 0         0 return @char;
1480             }
1481              
1482             #
1483             # Latin-10 open character class
1484             #
1485             sub _cc {
1486 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1487 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1488             }
1489             elsif (scalar(@_) == 1) {
1490 0         0 return sprintf('\x%02X',$_[0]);
1491             }
1492             elsif (scalar(@_) == 2) {
1493 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1494 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1495             }
1496             elsif ($_[0] == $_[1]) {
1497 0         0 return sprintf('\x%02X',$_[0]);
1498             }
1499             elsif (($_[0]+1) == $_[1]) {
1500 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1501             }
1502             else {
1503 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1504             }
1505             }
1506             else {
1507 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1508             }
1509             }
1510              
1511             #
1512             # Latin-10 octet range
1513             #
1514             sub _octets {
1515 0     182   0 my $length = shift @_;
1516              
1517 182 50       275 if ($length == 1) {
1518 182         348 my($a1) = unpack 'C', $_[0];
1519 182         487 my($z1) = unpack 'C', $_[1];
1520              
1521 182 50       318 if ($a1 > $z1) {
1522 182         347 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1523             }
1524              
1525 0 50       0 if ($a1 == $z1) {
    50          
1526 182         421 return sprintf('\x%02X',$a1);
1527             }
1528             elsif (($a1+1) == $z1) {
1529 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1530             }
1531             else {
1532 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1533             }
1534             }
1535             else {
1536 182         1069 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1537             }
1538             }
1539              
1540             #
1541             # Latin-10 range regexp
1542             #
1543             sub _range_regexp {
1544 0     182   0 my($length,$first,$last) = @_;
1545              
1546 182         375 my @range_regexp = ();
1547 182 50       238 if (not exists $range_tr{$length}) {
1548 182         418 return @range_regexp;
1549             }
1550              
1551 0         0 my @ranges = @{ $range_tr{$length} };
  182         268  
1552 182         727 while (my @range = splice(@ranges,0,$length)) {
1553 182         532 my $min = '';
1554 182         270 my $max = '';
1555 182         237 for (my $i=0; $i < $length; $i++) {
1556 182         481 $min .= pack 'C', $range[$i][0];
1557 182         734 $max .= pack 'C', $range[$i][-1];
1558             }
1559              
1560             # min___max
1561             # FIRST_____________LAST
1562             # (nothing)
1563              
1564 182 50 33     424 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1565             }
1566              
1567             # **********
1568             # min_________max
1569             # FIRST_____________LAST
1570             # **********
1571              
1572             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1573 182         1626 push @range_regexp, _octets($length,$first,$max,$min,$max);
1574             }
1575              
1576             # **********************
1577             # min________________max
1578             # FIRST_____________LAST
1579             # **********************
1580              
1581             elsif (($min eq $first) and ($max eq $last)) {
1582 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1583             }
1584              
1585             # *********
1586             # min___max
1587             # FIRST_____________LAST
1588             # *********
1589              
1590             elsif (($first le $min) and ($max le $last)) {
1591 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1592             }
1593              
1594             # **********************
1595             # min__________________________max
1596             # FIRST_____________LAST
1597             # **********************
1598              
1599             elsif (($min le $first) and ($last le $max)) {
1600 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1601             }
1602              
1603             # *********
1604             # min________max
1605             # FIRST_____________LAST
1606             # *********
1607              
1608             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1609 182         451 push @range_regexp, _octets($length,$min,$last,$min,$max);
1610             }
1611              
1612             # min___max
1613             # FIRST_____________LAST
1614             # (nothing)
1615              
1616             elsif ($last lt $min) {
1617             }
1618              
1619             else {
1620 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1621             }
1622             }
1623              
1624 0         0 return @range_regexp;
1625             }
1626              
1627             #
1628             # Latin-10 open character list for qr and not qr
1629             #
1630             sub _charlist {
1631              
1632 182     358   377 my $modifier = pop @_;
1633 358         535 my @char = @_;
1634              
1635 358 100       708 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1636              
1637             # unescape character
1638 358         782 for (my $i=0; $i <= $#char; $i++) {
1639              
1640             # escape - to ...
1641 358 100 100     1320 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1642 1125 100 100     8051 if ((0 < $i) and ($i < $#char)) {
1643 206         821 $char[$i] = '...';
1644             }
1645             }
1646              
1647             # octal escape sequence
1648             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1649 182         381 $char[$i] = octchr($1);
1650             }
1651              
1652             # hexadecimal escape sequence
1653             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1654 0         0 $char[$i] = hexchr($1);
1655             }
1656              
1657             # \b{...} --> b\{...}
1658             # \B{...} --> B\{...}
1659             # \N{CHARNAME} --> N\{CHARNAME}
1660             # \p{PROPERTY} --> p\{PROPERTY}
1661             # \P{PROPERTY} --> P\{PROPERTY}
1662             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1663 0         0 $char[$i] = $1 . '\\' . $2;
1664             }
1665              
1666             # \p, \P, \X --> p, P, X
1667             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1668 0         0 $char[$i] = $1;
1669             }
1670              
1671             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1672 0         0 $char[$i] = CORE::chr oct $1;
1673             }
1674             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1675 0         0 $char[$i] = CORE::chr hex $1;
1676             }
1677             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1678 22         93 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1679             }
1680             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1681             $char[$i] = {
1682             '\0' => "\0",
1683             '\n' => "\n",
1684             '\r' => "\r",
1685             '\t' => "\t",
1686             '\f' => "\f",
1687             '\b' => "\x08", # \b means backspace in character class
1688             '\a' => "\a",
1689             '\e' => "\e",
1690             '\d' => '[0-9]',
1691              
1692             # Vertical tabs are now whitespace
1693             # \s in a regex now matches a vertical tab in all circumstances.
1694             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1695             # \t \n \v \f \r space
1696             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1697             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1698             '\s' => '\s',
1699              
1700             '\w' => '[0-9A-Z_a-z]',
1701             '\D' => '${Elatin10::eD}',
1702             '\S' => '${Elatin10::eS}',
1703             '\W' => '${Elatin10::eW}',
1704              
1705             '\H' => '${Elatin10::eH}',
1706             '\V' => '${Elatin10::eV}',
1707             '\h' => '[\x09\x20]',
1708             '\v' => '[\x0A\x0B\x0C\x0D]',
1709             '\R' => '${Elatin10::eR}',
1710              
1711 0         0 }->{$1};
1712             }
1713              
1714             # POSIX-style character classes
1715             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1716             $char[$i] = {
1717              
1718             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1719             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1720             '[:^lower:]' => '${Elatin10::not_lower_i}',
1721             '[:^upper:]' => '${Elatin10::not_upper_i}',
1722              
1723 25         904 }->{$1};
1724             }
1725             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1726             $char[$i] = {
1727              
1728             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1729             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1730             '[:ascii:]' => '[\x00-\x7F]',
1731             '[:blank:]' => '[\x09\x20]',
1732             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1733             '[:digit:]' => '[\x30-\x39]',
1734             '[:graph:]' => '[\x21-\x7F]',
1735             '[:lower:]' => '[\x61-\x7A]',
1736             '[:print:]' => '[\x20-\x7F]',
1737             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1738              
1739             # P.174 POSIX-Style Character Classes
1740             # in Chapter 5: Pattern Matching
1741             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1742              
1743             # P.311 11.2.4 Character Classes and other Special Escapes
1744             # in Chapter 11: perlre: Perl regular expressions
1745             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1746              
1747             # P.210 POSIX-Style Character Classes
1748             # in Chapter 5: Pattern Matching
1749             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1750              
1751             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1752              
1753             '[:upper:]' => '[\x41-\x5A]',
1754             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1755             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1756             '[:^alnum:]' => '${Elatin10::not_alnum}',
1757             '[:^alpha:]' => '${Elatin10::not_alpha}',
1758             '[:^ascii:]' => '${Elatin10::not_ascii}',
1759             '[:^blank:]' => '${Elatin10::not_blank}',
1760             '[:^cntrl:]' => '${Elatin10::not_cntrl}',
1761             '[:^digit:]' => '${Elatin10::not_digit}',
1762             '[:^graph:]' => '${Elatin10::not_graph}',
1763             '[:^lower:]' => '${Elatin10::not_lower}',
1764             '[:^print:]' => '${Elatin10::not_print}',
1765             '[:^punct:]' => '${Elatin10::not_punct}',
1766             '[:^space:]' => '${Elatin10::not_space}',
1767             '[:^upper:]' => '${Elatin10::not_upper}',
1768             '[:^word:]' => '${Elatin10::not_word}',
1769             '[:^xdigit:]' => '${Elatin10::not_xdigit}',
1770              
1771 8         60 }->{$1};
1772             }
1773             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1774 70         1301 $char[$i] = $1;
1775             }
1776             }
1777              
1778             # open character list
1779 7         32 my @singleoctet = ();
1780 358         672 my @multipleoctet = ();
1781 358         494 for (my $i=0; $i <= $#char; ) {
1782              
1783             # escaped -
1784 358 100 100     870 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1785 943         4049 $i += 1;
1786 182         287 next;
1787             }
1788              
1789             # make range regexp
1790             elsif ($char[$i] eq '...') {
1791              
1792             # range error
1793 182 50       307 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1794 182         662 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1795             }
1796             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1797 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1798 182         499 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1799             }
1800             }
1801              
1802             # make range regexp per length
1803 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1804 182         495 my @regexp = ();
1805              
1806             # is first and last
1807 182 50 33     246 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1808 182         604 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1809             }
1810              
1811             # is first
1812             elsif ($length == CORE::length($char[$i-1])) {
1813 182         479 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1814             }
1815              
1816             # is inside in first and last
1817             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1818 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1819             }
1820              
1821             # is last
1822             elsif ($length == CORE::length($char[$i+1])) {
1823 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1824             }
1825              
1826             else {
1827 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1828             }
1829              
1830 0 50       0 if ($length == 1) {
1831 182         365 push @singleoctet, @regexp;
1832             }
1833             else {
1834 182         394 push @multipleoctet, @regexp;
1835             }
1836             }
1837              
1838 0         0 $i += 2;
1839             }
1840              
1841             # with /i modifier
1842             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1843 182 100       391 if ($modifier =~ /i/oxms) {
1844 493         765 my $uc = Elatin10::uc($char[$i]);
1845 24         65 my $fc = Elatin10::fc($char[$i]);
1846 24 100       53 if ($uc ne $fc) {
1847 24 50       48 if (CORE::length($fc) == 1) {
1848 12         25 push @singleoctet, $uc, $fc;
1849             }
1850             else {
1851 12         18 push @singleoctet, $uc;
1852 0         0 push @multipleoctet, $fc;
1853             }
1854             }
1855             else {
1856 0         0 push @singleoctet, $char[$i];
1857             }
1858             }
1859             else {
1860 12         27 push @singleoctet, $char[$i];
1861             }
1862 469         740 $i += 1;
1863             }
1864              
1865             # single character of single octet code
1866             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1867 493         783 push @singleoctet, "\t", "\x20";
1868 0         0 $i += 1;
1869             }
1870             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1871 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1872 0         0 $i += 1;
1873             }
1874             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1875 0         0 push @singleoctet, $char[$i];
1876 2         6 $i += 1;
1877             }
1878              
1879             # single character of multiple-octet code
1880             else {
1881 2         4 push @multipleoctet, $char[$i];
1882 84         169 $i += 1;
1883             }
1884             }
1885              
1886             # quote metachar
1887 84         152 for (@singleoctet) {
1888 358 50       699 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1889 689         3010 $_ = '-';
1890             }
1891             elsif (/\A \n \z/oxms) {
1892 0         0 $_ = '\n';
1893             }
1894             elsif (/\A \r \z/oxms) {
1895 8         15 $_ = '\r';
1896             }
1897             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1898 8         16 $_ = sprintf('\x%02X', CORE::ord $1);
1899             }
1900             elsif (/\A [\x00-\xFF] \z/oxms) {
1901 60         202 $_ = quotemeta $_;
1902             }
1903             }
1904              
1905             # return character list
1906 429         642 return \@singleoctet, \@multipleoctet;
1907             }
1908              
1909             #
1910             # Latin-10 octal escape sequence
1911             #
1912             sub octchr {
1913 358     5 0 1140 my($octdigit) = @_;
1914              
1915 5         12 my @binary = ();
1916 5         8 for my $octal (split(//,$octdigit)) {
1917             push @binary, {
1918             '0' => '000',
1919             '1' => '001',
1920             '2' => '010',
1921             '3' => '011',
1922             '4' => '100',
1923             '5' => '101',
1924             '6' => '110',
1925             '7' => '111',
1926 5         25 }->{$octal};
1927             }
1928 50         184 my $binary = join '', @binary;
1929              
1930             my $octchr = {
1931             # 1234567
1932             1 => pack('B*', "0000000$binary"),
1933             2 => pack('B*', "000000$binary"),
1934             3 => pack('B*', "00000$binary"),
1935             4 => pack('B*', "0000$binary"),
1936             5 => pack('B*', "000$binary"),
1937             6 => pack('B*', "00$binary"),
1938             7 => pack('B*', "0$binary"),
1939             0 => pack('B*', "$binary"),
1940              
1941 5         14 }->{CORE::length($binary) % 8};
1942              
1943 5         55 return $octchr;
1944             }
1945              
1946             #
1947             # Latin-10 hexadecimal escape sequence
1948             #
1949             sub hexchr {
1950 5     5 0 21 my($hexdigit) = @_;
1951              
1952             my $hexchr = {
1953             1 => pack('H*', "0$hexdigit"),
1954             0 => pack('H*', "$hexdigit"),
1955              
1956 5         15 }->{CORE::length($_[0]) % 2};
1957              
1958 5         36 return $hexchr;
1959             }
1960              
1961             #
1962             # Latin-10 open character list for qr
1963             #
1964             sub charlist_qr {
1965              
1966 5     314 0 18 my $modifier = pop @_;
1967 314         637 my @char = @_;
1968              
1969 314         760 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1970 314         974 my @singleoctet = @$singleoctet;
1971 314         689 my @multipleoctet = @$multipleoctet;
1972              
1973             # return character list
1974 314 100       481 if (scalar(@singleoctet) >= 1) {
1975              
1976             # with /i modifier
1977 314 100       674 if ($modifier =~ m/i/oxms) {
1978 236         571 my %singleoctet_ignorecase = ();
1979 22         36 for (@singleoctet) {
1980 22   100     36 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1981 46         201 for my $ord (hex($1) .. hex($2)) {
1982 46         140 my $char = CORE::chr($ord);
1983 66         93 my $uc = Elatin10::uc($char);
1984 66         101 my $fc = Elatin10::fc($char);
1985 66 100       110 if ($uc eq $fc) {
1986 66         103 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1987             }
1988             else {
1989 12 50       77 if (CORE::length($fc) == 1) {
1990 54         86 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1991 54         107 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1992             }
1993             else {
1994 54         188 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1995 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1996             }
1997             }
1998             }
1999             }
2000 0 50       0 if ($_ ne '') {
2001 46         116 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2002             }
2003             }
2004 0         0 my $i = 0;
2005 22         29 my @singleoctet_ignorecase = ();
2006 22         33 for my $ord (0 .. 255) {
2007 22 100       37 if (exists $singleoctet_ignorecase{$ord}) {
2008 5632         6437 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         93  
2009             }
2010             else {
2011 96         226 $i++;
2012             }
2013             }
2014 5536         5489 @singleoctet = ();
2015 22         33 for my $range (@singleoctet_ignorecase) {
2016 22 100       95 if (ref $range) {
2017 3648 100       5581 if (scalar(@{$range}) == 1) {
  56 50       57  
2018 56         85 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         41  
2019             }
2020 36         118 elsif (scalar(@{$range}) == 2) {
2021 20         31 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2022             }
2023             else {
2024 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         24  
  20         24  
2025             }
2026             }
2027             }
2028             }
2029              
2030 20         76 my $not_anchor = '';
2031              
2032 236         349 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2033             }
2034 236 100       659 if (scalar(@multipleoctet) >= 2) {
2035 314         621 return '(?:' . join('|', @multipleoctet) . ')';
2036             }
2037             else {
2038 6         30 return $multipleoctet[0];
2039             }
2040             }
2041              
2042             #
2043             # Latin-10 open character list for not qr
2044             #
2045             sub charlist_not_qr {
2046              
2047 308     44 0 1268 my $modifier = pop @_;
2048 44         82 my @char = @_;
2049              
2050 44         96 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2051 44         121 my @singleoctet = @$singleoctet;
2052 44         95 my @multipleoctet = @$multipleoctet;
2053              
2054             # with /i modifier
2055 44 100       70 if ($modifier =~ m/i/oxms) {
2056 44         96 my %singleoctet_ignorecase = ();
2057 10         14 for (@singleoctet) {
2058 10   66     16 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2059 10         41 for my $ord (hex($1) .. hex($2)) {
2060 10         31 my $char = CORE::chr($ord);
2061 30         44 my $uc = Elatin10::uc($char);
2062 30         44 my $fc = Elatin10::fc($char);
2063 30 50       52 if ($uc eq $fc) {
2064 30         46 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2065             }
2066             else {
2067 0 50       0 if (CORE::length($fc) == 1) {
2068 30         37 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2069 30         63 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2070             }
2071             else {
2072 30         86 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2073 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2074             }
2075             }
2076             }
2077             }
2078 0 50       0 if ($_ ne '') {
2079 10         33 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2080             }
2081             }
2082 0         0 my $i = 0;
2083 10         18 my @singleoctet_ignorecase = ();
2084 10         13 for my $ord (0 .. 255) {
2085 10 100       13 if (exists $singleoctet_ignorecase{$ord}) {
2086 2560         2897 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         58  
2087             }
2088             else {
2089 60         102 $i++;
2090             }
2091             }
2092 2500         2815 @singleoctet = ();
2093 10         16 for my $range (@singleoctet_ignorecase) {
2094 10 100       22 if (ref $range) {
2095 960 50       1506 if (scalar(@{$range}) == 1) {
  20 50       21  
2096 20         29 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2097             }
2098 0         0 elsif (scalar(@{$range}) == 2) {
2099 20         29 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2100             }
2101             else {
2102 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         23  
2103             }
2104             }
2105             }
2106             }
2107              
2108             # return character list
2109 20 50       80 if (scalar(@multipleoctet) >= 1) {
2110 44 0       98 if (scalar(@singleoctet) >= 1) {
2111              
2112             # any character other than multiple-octet and single octet character class
2113 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2114             }
2115             else {
2116              
2117             # any character other than multiple-octet character class
2118 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2119             }
2120             }
2121             else {
2122 0 50       0 if (scalar(@singleoctet) >= 1) {
2123              
2124             # any character other than single octet character class
2125 44         94 return '(?:[^' . join('', @singleoctet) . '])';
2126             }
2127             else {
2128              
2129             # any character
2130 44         237 return "(?:$your_char)";
2131             }
2132             }
2133             }
2134              
2135             #
2136             # open file in read mode
2137             #
2138             sub _open_r {
2139 0     408   0 my(undef,$file) = @_;
2140 204     204   2137 use Fcntl qw(O_RDONLY);
  204         439  
  204         28805  
2141 408         1148 return CORE::sysopen($_[0], $file, &O_RDONLY);
2142             }
2143              
2144             #
2145             # open file in append mode
2146             #
2147             sub _open_a {
2148 408     204   16749 my(undef,$file) = @_;
2149 204     204   1423 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         474  
  204         671641  
2150 204         665 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2151             }
2152              
2153             #
2154             # safe system
2155             #
2156             sub _systemx {
2157              
2158             # P.707 29.2.33. exec
2159             # in Chapter 29: Functions
2160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2161             #
2162             # Be aware that in older releases of Perl, exec (and system) did not flush
2163             # your output buffer, so you needed to enable command buffering by setting $|
2164             # on one or more filehandles to avoid lost output in the case of exec, or
2165             # misordererd output in the case of system. This situation was largely remedied
2166             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2167              
2168             # P.855 exec
2169             # in Chapter 27: Functions
2170             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2171             #
2172             # In very old release of Perl (before v5.6), exec (and system) did not flush
2173             # your output buffer, so you needed to enable command buffering by setting $|
2174             # on one or more filehandles to avoid lost output with exec or misordered
2175             # output with system.
2176              
2177 204     204   33120 $| = 1;
2178              
2179             # P.565 23.1.2. Cleaning Up Your Environment
2180             # in Chapter 23: Security
2181             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2182              
2183             # P.656 Cleaning Up Your Environment
2184             # in Chapter 20: Security
2185             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2186              
2187             # local $ENV{'PATH'} = '.';
2188 204         690 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2189              
2190             # P.707 29.2.33. exec
2191             # in Chapter 29: Functions
2192             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2193             #
2194             # As we mentioned earlier, exec treats a discrete list of arguments as an
2195             # indication that it should bypass shell processing. However, there is one
2196             # place where you might still get tripped up. The exec call (and system, too)
2197             # will not distinguish between a single scalar argument and an array containing
2198             # only one element.
2199             #
2200             # @args = ("echo surprise"); # just one element in list
2201             # exec @args # still subject to shell escapes
2202             # or die "exec: $!"; # because @args == 1
2203             #
2204             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2205             # first argument as the pathname, which forces the rest of the arguments to be
2206             # interpreted as a list, even if there is only one of them:
2207             #
2208             # exec { $args[0] } @args # safe even with one-argument list
2209             # or die "can't exec @args: $!";
2210              
2211             # P.855 exec
2212             # in Chapter 27: Functions
2213             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2214             #
2215             # As we mentioned earlier, exec treats a discrete list of arguments as a
2216             # directive to bypass shell processing. However, there is one place where
2217             # you might still get tripped up. The exec call (and system, too) cannot
2218             # distinguish between a single scalar argument and an array containing
2219             # only one element.
2220             #
2221             # @args = ("echo surprise"); # just one element in list
2222             # exec @args # still subject to shell escapes
2223             # || die "exec: $!"; # because @args == 1
2224             #
2225             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2226             # argument as the pathname, which forces the rest of the arguments to be
2227             # interpreted as a list, even if there is only one of them:
2228             #
2229             # exec { $args[0] } @args # safe even with one-argument list
2230             # || die "can't exec @args: $!";
2231              
2232 204         1864 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         426  
2233             }
2234              
2235             #
2236             # Latin-10 order to character (with parameter)
2237             #
2238             sub Elatin10::chr(;$) {
2239              
2240 204 0   0 0 18433794 my $c = @_ ? $_[0] : $_;
2241              
2242 0 0       0 if ($c == 0x00) {
2243 0         0 return "\x00";
2244             }
2245             else {
2246 0         0 my @chr = ();
2247 0         0 while ($c > 0) {
2248 0         0 unshift @chr, ($c % 0x100);
2249 0         0 $c = int($c / 0x100);
2250             }
2251 0         0 return pack 'C*', @chr;
2252             }
2253             }
2254              
2255             #
2256             # Latin-10 order to character (without parameter)
2257             #
2258             sub Elatin10::chr_() {
2259              
2260 0     0 0 0 my $c = $_;
2261              
2262 0 0       0 if ($c == 0x00) {
2263 0         0 return "\x00";
2264             }
2265             else {
2266 0         0 my @chr = ();
2267 0         0 while ($c > 0) {
2268 0         0 unshift @chr, ($c % 0x100);
2269 0         0 $c = int($c / 0x100);
2270             }
2271 0         0 return pack 'C*', @chr;
2272             }
2273             }
2274              
2275             #
2276             # Latin-10 path globbing (with parameter)
2277             #
2278             sub Elatin10::glob($) {
2279              
2280 0 0   0 0 0 if (wantarray) {
2281 0         0 my @glob = _DOS_like_glob(@_);
2282 0         0 for my $glob (@glob) {
2283 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2284             }
2285 0         0 return @glob;
2286             }
2287             else {
2288 0         0 my $glob = _DOS_like_glob(@_);
2289 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2290 0         0 return $glob;
2291             }
2292             }
2293              
2294             #
2295             # Latin-10 path globbing (without parameter)
2296             #
2297             sub Elatin10::glob_() {
2298              
2299 0 0   0 0 0 if (wantarray) {
2300 0         0 my @glob = _DOS_like_glob();
2301 0         0 for my $glob (@glob) {
2302 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2303             }
2304 0         0 return @glob;
2305             }
2306             else {
2307 0         0 my $glob = _DOS_like_glob();
2308 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2309 0         0 return $glob;
2310             }
2311             }
2312              
2313             #
2314             # Latin-10 path globbing via File::DosGlob 1.10
2315             #
2316             # Often I confuse "_dosglob" and "_doglob".
2317             # So, I renamed "_dosglob" to "_DOS_like_glob".
2318             #
2319             my %iter;
2320             my %entries;
2321             sub _DOS_like_glob {
2322              
2323             # context (keyed by second cxix argument provided by core)
2324 0     0   0 my($expr,$cxix) = @_;
2325              
2326             # glob without args defaults to $_
2327 0 0       0 $expr = $_ if not defined $expr;
2328              
2329             # represents the current user's home directory
2330             #
2331             # 7.3. Expanding Tildes in Filenames
2332             # in Chapter 7. File Access
2333             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2334             #
2335             # and File::HomeDir, File::HomeDir::Windows module
2336              
2337             # DOS-like system
2338 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2339 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2340             { my_home_MSWin32() }oxmse;
2341             }
2342              
2343             # UNIX-like system
2344 0 0 0     0 else {
  0         0  
2345             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2346             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2347             }
2348 0 0       0  
2349 0 0       0 # assume global context if not provided one
2350             $cxix = '_G_' if not defined $cxix;
2351             $iter{$cxix} = 0 if not exists $iter{$cxix};
2352 0 0       0  
2353 0         0 # if we're just beginning, do it all first
2354             if ($iter{$cxix} == 0) {
2355             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2356             }
2357 0 0       0  
2358 0         0 # chuck it all out, quick or slow
2359 0         0 if (wantarray) {
  0         0  
2360             delete $iter{$cxix};
2361             return @{delete $entries{$cxix}};
2362 0 0       0 }
  0         0  
2363 0         0 else {
  0         0  
2364             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2365             return shift @{$entries{$cxix}};
2366             }
2367 0         0 else {
2368 0         0 # return undef for EOL
2369 0         0 delete $iter{$cxix};
2370             delete $entries{$cxix};
2371             return undef;
2372             }
2373             }
2374             }
2375              
2376             #
2377             # Latin-10 path globbing subroutine
2378             #
2379 0     0   0 sub _do_glob {
2380 0         0  
2381 0         0 my($cond,@expr) = @_;
2382             my @glob = ();
2383             my $fix_drive_relative_paths = 0;
2384 0         0  
2385 0 0       0 OUTER:
2386 0 0       0 for my $expr (@expr) {
2387             next OUTER if not defined $expr;
2388 0         0 next OUTER if $expr eq '';
2389 0         0  
2390 0         0 my @matched = ();
2391 0         0 my @globdir = ();
2392 0         0 my $head = '.';
2393             my $pathsep = '/';
2394             my $tail;
2395 0 0       0  
2396 0         0 # if argument is within quotes strip em and do no globbing
2397 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2398 0 0       0 $expr = $1;
2399 0         0 if ($cond eq 'd') {
2400             if (-d $expr) {
2401             push @glob, $expr;
2402             }
2403 0 0       0 }
2404 0         0 else {
2405             if (-e $expr) {
2406             push @glob, $expr;
2407 0         0 }
2408             }
2409             next OUTER;
2410             }
2411              
2412 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2413 0 0       0 # to h:./*.pm to expand correctly
2414 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2415             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2416             $fix_drive_relative_paths = 1;
2417             }
2418 0 0       0 }
2419 0 0       0  
2420 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2421 0         0 if ($tail eq '') {
2422             push @glob, $expr;
2423 0 0       0 next OUTER;
2424 0 0       0 }
2425 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2426 0         0 if (@globdir = _do_glob('d', $head)) {
2427             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2428             next OUTER;
2429 0 0 0     0 }
2430 0         0 }
2431             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2432 0         0 $head .= $pathsep;
2433             }
2434             $expr = $tail;
2435             }
2436 0 0       0  
2437 0 0       0 # If file component has no wildcards, we can avoid opendir
2438 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2439             if ($head eq '.') {
2440 0 0 0     0 $head = '';
2441 0         0 }
2442             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2443 0         0 $head .= $pathsep;
2444 0 0       0 }
2445 0 0       0 $head .= $expr;
2446 0         0 if ($cond eq 'd') {
2447             if (-d $head) {
2448             push @glob, $head;
2449             }
2450 0 0       0 }
2451 0         0 else {
2452             if (-e $head) {
2453             push @glob, $head;
2454 0         0 }
2455             }
2456 0 0       0 next OUTER;
2457 0         0 }
2458 0         0 opendir(*DIR, $head) or next OUTER;
2459             my @leaf = readdir DIR;
2460 0 0       0 closedir DIR;
2461 0         0  
2462             if ($head eq '.') {
2463 0 0 0     0 $head = '';
2464 0         0 }
2465             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2466             $head .= $pathsep;
2467 0         0 }
2468 0         0  
2469 0         0 my $pattern = '';
2470             while ($expr =~ / \G ($q_char) /oxgc) {
2471             my $char = $1;
2472              
2473             # 6.9. Matching Shell Globs as Regular Expressions
2474             # in Chapter 6. Pattern Matching
2475             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2476 0 0       0 # (and so on)
    0          
    0          
2477 0         0  
2478             if ($char eq '*') {
2479             $pattern .= "(?:$your_char)*",
2480 0         0 }
2481             elsif ($char eq '?') {
2482             $pattern .= "(?:$your_char)?", # DOS style
2483             # $pattern .= "(?:$your_char)", # UNIX style
2484 0         0 }
2485             elsif ((my $fc = Elatin10::fc($char)) ne $char) {
2486             $pattern .= $fc;
2487 0         0 }
2488             else {
2489             $pattern .= quotemeta $char;
2490 0     0   0 }
  0         0  
2491             }
2492             my $matchsub = sub { Elatin10::fc($_[0]) =~ /\A $pattern \z/xms };
2493              
2494             # if ($@) {
2495             # print STDERR "$0: $@\n";
2496             # next OUTER;
2497             # }
2498 0         0  
2499 0 0 0     0 INNER:
2500 0         0 for my $leaf (@leaf) {
2501             if ($leaf eq '.' or $leaf eq '..') {
2502 0 0 0     0 next INNER;
2503 0         0 }
2504             if ($cond eq 'd' and not -d "$head$leaf") {
2505             next INNER;
2506 0 0       0 }
2507 0         0  
2508 0         0 if (&$matchsub($leaf)) {
2509             push @matched, "$head$leaf";
2510             next INNER;
2511             }
2512              
2513             # [DOS compatibility special case]
2514 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2515              
2516             if (Elatin10::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2517             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2518 0 0       0 Elatin10::index($pattern,'\\.') != -1 # pattern has a dot.
2519 0         0 ) {
2520 0         0 if (&$matchsub("$leaf.")) {
2521             push @matched, "$head$leaf";
2522             next INNER;
2523             }
2524 0 0       0 }
2525 0         0 }
2526             if (@matched) {
2527             push @glob, @matched;
2528 0 0       0 }
2529 0         0 }
2530 0         0 if ($fix_drive_relative_paths) {
2531             for my $glob (@glob) {
2532             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2533 0         0 }
2534             }
2535             return @glob;
2536             }
2537              
2538             #
2539             # Latin-10 parse line
2540             #
2541 0     0   0 sub _parse_line {
2542              
2543 0         0 my($line) = @_;
2544 0         0  
2545 0         0 $line .= ' ';
2546             my @piece = ();
2547             while ($line =~ /
2548             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2549             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2550 0 0       0 /oxmsg
2551             ) {
2552 0         0 push @piece, defined($1) ? $1 : $2;
2553             }
2554             return @piece;
2555             }
2556              
2557             #
2558             # Latin-10 parse path
2559             #
2560 0     0   0 sub _parse_path {
2561              
2562 0         0 my($path,$pathsep) = @_;
2563 0         0  
2564 0         0 $path .= '/';
2565             my @subpath = ();
2566             while ($path =~ /
2567             ((?: [^\/\\] )+?) [\/\\]
2568 0         0 /oxmsg
2569             ) {
2570             push @subpath, $1;
2571 0         0 }
2572 0         0  
2573 0         0 my $tail = pop @subpath;
2574             my $head = join $pathsep, @subpath;
2575             return $head, $tail;
2576             }
2577              
2578             #
2579             # via File::HomeDir::Windows 1.00
2580             #
2581             sub my_home_MSWin32 {
2582              
2583             # A lot of unix people and unix-derived tools rely on
2584 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2585 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2586             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2587             return $ENV{'HOME'};
2588             }
2589              
2590 0         0 # Do we have a user profile?
2591             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2592             return $ENV{'USERPROFILE'};
2593             }
2594              
2595 0         0 # Some Windows use something like $ENV{'HOME'}
2596             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2597             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2598 0         0 }
2599              
2600             return undef;
2601             }
2602              
2603             #
2604             # via File::HomeDir::Unix 1.00
2605 0     0 0 0 #
2606             sub my_home {
2607 0 0 0     0 my $home;
    0 0        
2608 0         0  
2609             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2610             $home = $ENV{'HOME'};
2611             }
2612              
2613             # This is from the original code, but I'm guessing
2614 0         0 # it means "login directory" and exists on some Unixes.
2615             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2616             $home = $ENV{'LOGDIR'};
2617             }
2618              
2619             ### More-desperate methods
2620              
2621 0         0 # Light desperation on any (Unixish) platform
2622             else {
2623             $home = CORE::eval q{ (getpwuid($<))[7] };
2624             }
2625              
2626 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2627 0         0 # For example, "nobody"-like users might use /nonexistant
2628             if (defined $home and ! -d($home)) {
2629 0         0 $home = undef;
2630             }
2631             return $home;
2632             }
2633              
2634             #
2635             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2636 0     0 0 0 #
2637             sub Elatin10::PREMATCH {
2638             return $`;
2639             }
2640              
2641             #
2642             # ${^MATCH}, $MATCH, $& the string that matched
2643 0     0 0 0 #
2644             sub Elatin10::MATCH {
2645             return $&;
2646             }
2647              
2648             #
2649             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2650 0     0 0 0 #
2651             sub Elatin10::POSTMATCH {
2652             return $';
2653             }
2654              
2655             #
2656             # Latin-10 character to order (with parameter)
2657             #
2658 0 0   0 1 0 sub Latin10::ord(;$) {
2659              
2660 0 0       0 local $_ = shift if @_;
2661 0         0  
2662 0         0 if (/\A ($q_char) /oxms) {
2663 0         0 my @ord = unpack 'C*', $1;
2664 0         0 my $ord = 0;
2665             while (my $o = shift @ord) {
2666 0         0 $ord = $ord * 0x100 + $o;
2667             }
2668             return $ord;
2669 0         0 }
2670             else {
2671             return CORE::ord $_;
2672             }
2673             }
2674              
2675             #
2676             # Latin-10 character to order (without parameter)
2677             #
2678 0 0   0 0 0 sub Latin10::ord_() {
2679 0         0  
2680 0         0 if (/\A ($q_char) /oxms) {
2681 0         0 my @ord = unpack 'C*', $1;
2682 0         0 my $ord = 0;
2683             while (my $o = shift @ord) {
2684 0         0 $ord = $ord * 0x100 + $o;
2685             }
2686             return $ord;
2687 0         0 }
2688             else {
2689             return CORE::ord $_;
2690             }
2691             }
2692              
2693             #
2694             # Latin-10 reverse
2695             #
2696 0 0   0 0 0 sub Latin10::reverse(@) {
2697 0         0  
2698             if (wantarray) {
2699             return CORE::reverse @_;
2700             }
2701             else {
2702              
2703             # One of us once cornered Larry in an elevator and asked him what
2704             # problem he was solving with this, but he looked as far off into
2705             # the distance as he could in an elevator and said, "It seemed like
2706 0         0 # a good idea at the time."
2707              
2708             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2709             }
2710             }
2711              
2712             #
2713             # Latin-10 getc (with parameter, without parameter)
2714             #
2715 0     0 0 0 sub Latin10::getc(;*@) {
2716 0 0       0  
2717 0 0 0     0 my($package) = caller;
2718             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2719 0         0 croak 'Too many arguments for Latin10::getc' if @_ and not wantarray;
  0         0  
2720 0         0  
2721 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2722 0         0 my $getc = '';
2723 0 0       0 for my $length ($length[0] .. $length[-1]) {
2724 0 0       0 $getc .= CORE::getc($fh);
2725 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2726             if ($getc =~ /\A ${Elatin10::dot_s} \z/oxms) {
2727             return wantarray ? ($getc,@_) : $getc;
2728             }
2729 0 0       0 }
2730             }
2731             return wantarray ? ($getc,@_) : $getc;
2732             }
2733              
2734             #
2735             # Latin-10 length by character
2736             #
2737 0 0   0 1 0 sub Latin10::length(;$) {
2738              
2739 0         0 local $_ = shift if @_;
2740 0         0  
2741             local @_ = /\G ($q_char) /oxmsg;
2742             return scalar @_;
2743             }
2744              
2745             #
2746             # Latin-10 substr by character
2747             #
2748             BEGIN {
2749              
2750             # P.232 The lvalue Attribute
2751             # in Chapter 6: Subroutines
2752             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2753              
2754             # P.336 The lvalue Attribute
2755             # in Chapter 7: Subroutines
2756             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2757              
2758             # P.144 8.4 Lvalue subroutines
2759             # in Chapter 8: perlsub: Perl subroutines
2760 204 50 0 204 1 146021 # 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  
2761              
2762             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2763             # vv----------------------*******
2764             sub Latin10::substr($$;$$) %s {
2765              
2766             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2767              
2768             # If the substring is beyond either end of the string, substr() returns the undefined
2769             # value and produces a warning. When used as an lvalue, specifying a substring that
2770             # is entirely outside the string raises an exception.
2771             # http://perldoc.perl.org/functions/substr.html
2772              
2773             # A return with no argument returns the scalar value undef in scalar context,
2774             # an empty list () in list context, and (naturally) nothing at all in void
2775             # context.
2776              
2777             my $offset = $_[1];
2778             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2779             return;
2780             }
2781              
2782             # substr($string,$offset,$length,$replacement)
2783             if (@_ == 4) {
2784             my(undef,undef,$length,$replacement) = @_;
2785             my $substr = join '', splice(@char, $offset, $length, $replacement);
2786             $_[0] = join '', @char;
2787              
2788             # return $substr; this doesn't work, don't say "return"
2789             $substr;
2790             }
2791              
2792             # substr($string,$offset,$length)
2793             elsif (@_ == 3) {
2794             my(undef,undef,$length) = @_;
2795             my $octet_offset = 0;
2796             my $octet_length = 0;
2797             if ($offset == 0) {
2798             $octet_offset = 0;
2799             }
2800             elsif ($offset > 0) {
2801             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2802             }
2803             else {
2804             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2805             }
2806             if ($length == 0) {
2807             $octet_length = 0;
2808             }
2809             elsif ($length > 0) {
2810             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2811             }
2812             else {
2813             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2814             }
2815             CORE::substr($_[0], $octet_offset, $octet_length);
2816             }
2817              
2818             # substr($string,$offset)
2819             else {
2820             my $octet_offset = 0;
2821             if ($offset == 0) {
2822             $octet_offset = 0;
2823             }
2824             elsif ($offset > 0) {
2825             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2826             }
2827             else {
2828             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2829             }
2830             CORE::substr($_[0], $octet_offset);
2831             }
2832             }
2833             END
2834             }
2835              
2836             #
2837             # Latin-10 index by character
2838             #
2839 0     0 1 0 sub Latin10::index($$;$) {
2840 0 0       0  
2841 0         0 my $index;
2842             if (@_ == 3) {
2843             $index = Elatin10::index($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2844 0         0 }
2845             else {
2846             $index = Elatin10::index($_[0], $_[1]);
2847 0 0       0 }
2848 0         0  
2849             if ($index == -1) {
2850             return -1;
2851 0         0 }
2852             else {
2853             return Latin10::length(CORE::substr $_[0], 0, $index);
2854             }
2855             }
2856              
2857             #
2858             # Latin-10 rindex by character
2859             #
2860 0     0 1 0 sub Latin10::rindex($$;$) {
2861 0 0       0  
2862 0         0 my $rindex;
2863             if (@_ == 3) {
2864             $rindex = Elatin10::rindex($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2865 0         0 }
2866             else {
2867             $rindex = Elatin10::rindex($_[0], $_[1]);
2868 0 0       0 }
2869 0         0  
2870             if ($rindex == -1) {
2871             return -1;
2872 0         0 }
2873             else {
2874             return Latin10::length(CORE::substr $_[0], 0, $rindex);
2875             }
2876             }
2877              
2878 204     204   1690 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         442  
  204         23798  
2879             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2880             use vars qw($slash); $slash = 'm//';
2881              
2882             # ord() to ord() or Latin10::ord()
2883             my $function_ord = 'ord';
2884              
2885             # ord to ord or Latin10::ord_
2886             my $function_ord_ = 'ord';
2887              
2888             # reverse to reverse or Latin10::reverse
2889             my $function_reverse = 'reverse';
2890              
2891             # getc to getc or Latin10::getc
2892             my $function_getc = 'getc';
2893              
2894             # P.1023 Appendix W.9 Multibyte Anchoring
2895             # of ISBN 1-56592-224-7 CJKV Information Processing
2896              
2897 204     204   2125 my $anchor = '';
  204     0   351  
  204         9171918  
2898              
2899             use vars qw($nest);
2900              
2901             # regexp of nested parens in qqXX
2902              
2903             # P.340 Matching Nested Constructs with Embedded Code
2904             # in Chapter 7: Perl
2905             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2906              
2907             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2908             [^\\()] |
2909             \( (?{$nest++}) |
2910             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2911             \\ [^c] |
2912             \\c[\x40-\x5F] |
2913             [\x00-\xFF]
2914             }xms;
2915              
2916             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2917             [^\\{}] |
2918             \{ (?{$nest++}) |
2919             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2920             \\ [^c] |
2921             \\c[\x40-\x5F] |
2922             [\x00-\xFF]
2923             }xms;
2924              
2925             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2926             [^\\\[\]] |
2927             \[ (?{$nest++}) |
2928             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2929             \\ [^c] |
2930             \\c[\x40-\x5F] |
2931             [\x00-\xFF]
2932             }xms;
2933              
2934             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2935             [^\\<>] |
2936             \< (?{$nest++}) |
2937             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2938             \\ [^c] |
2939             \\c[\x40-\x5F] |
2940             [\x00-\xFF]
2941             }xms;
2942              
2943             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2944             (?: ::)? (?:
2945             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2946             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2947             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2948             ))
2949             }xms;
2950              
2951             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2952             (?: ::)? (?:
2953             (?>[0-9]+) |
2954             [^a-zA-Z_0-9\[\]] |
2955             ^[A-Z] |
2956             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2957             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2958             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2959             ))
2960             }xms;
2961              
2962             my $qq_substr = qr{(?> Char::substr | Latin10::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2963             }xms;
2964              
2965             # regexp of nested parens in qXX
2966             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2967             [^()] |
2968             \( (?{$nest++}) |
2969             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2970             [\x00-\xFF]
2971             }xms;
2972              
2973             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2974             [^\{\}] |
2975             \{ (?{$nest++}) |
2976             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2977             [\x00-\xFF]
2978             }xms;
2979              
2980             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2981             [^\[\]] |
2982             \[ (?{$nest++}) |
2983             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2984             [\x00-\xFF]
2985             }xms;
2986              
2987             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2988             [^<>] |
2989             \< (?{$nest++}) |
2990             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2991             [\x00-\xFF]
2992             }xms;
2993              
2994             my $matched = '';
2995             my $s_matched = '';
2996              
2997             my $tr_variable = ''; # variable of tr///
2998             my $sub_variable = ''; # variable of s///
2999             my $bind_operator = ''; # =~ or !~
3000              
3001             my @heredoc = (); # here document
3002             my @heredoc_delimiter = ();
3003             my $here_script = ''; # here script
3004              
3005             #
3006             # escape Latin-10 script
3007 0 50   204 0 0 #
3008             sub Latin10::escape(;$) {
3009             local($_) = $_[0] if @_;
3010              
3011             # P.359 The Study Function
3012             # in Chapter 7: Perl
3013 204         618 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3014              
3015             study $_; # Yes, I studied study yesterday.
3016              
3017             # while all script
3018              
3019             # 6.14. Matching from Where the Last Pattern Left Off
3020             # in Chapter 6. Pattern Matching
3021             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3022             # (and so on)
3023              
3024             # one member of Tag-team
3025             #
3026             # P.128 Start of match (or end of previous match): \G
3027             # P.130 Advanced Use of \G with Perl
3028             # in Chapter 3: Overview of Regular Expression Features and Flavors
3029             # P.255 Use leading anchors
3030             # P.256 Expose ^ and \G at the front expressions
3031             # in Chapter 6: Crafting an Efficient Expression
3032             # P.315 "Tag-team" matching with /gc
3033             # in Chapter 7: Perl
3034 204         1932 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3035 204         367  
3036 204         800 my $e_script = '';
3037             while (not /\G \z/oxgc) { # member
3038             $e_script .= Latin10::escape_token();
3039 75131         112245 }
3040              
3041             return $e_script;
3042             }
3043              
3044             #
3045             # escape Latin-10 token of script
3046             #
3047             sub Latin10::escape_token {
3048              
3049 204     75131 0 3922 # \n output here document
3050              
3051             my $ignore_modules = join('|', qw(
3052             utf8
3053             bytes
3054             charnames
3055             I18N::Japanese
3056             I18N::Collate
3057             I18N::JExt
3058             File::DosGlob
3059             Wild
3060             Wildcard
3061             Japanese
3062             ));
3063              
3064             # another member of Tag-team
3065             #
3066             # P.315 "Tag-team" matching with /gc
3067             # in Chapter 7: Perl
3068 75131 100 100     90187 # 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          
3069 75131         2831478  
3070 12535 100       16687 if (/\G ( \n ) /oxgc) { # another member (and so on)
3071 12535         21607 my $heredoc = '';
3072             if (scalar(@heredoc_delimiter) >= 1) {
3073 174         223 $slash = 'm//';
3074 174         344  
3075             $heredoc = join '', @heredoc;
3076             @heredoc = ();
3077 174         281  
3078 174         326 # skip here document
3079             for my $heredoc_delimiter (@heredoc_delimiter) {
3080 174         1081 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3081             }
3082 174         298 @heredoc_delimiter = ();
3083              
3084 174         281 $here_script = '';
3085             }
3086             return "\n" . $heredoc;
3087             }
3088 12535         35143  
3089             # ignore space, comment
3090             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3091              
3092             # if (, elsif (, unless (, while (, until (, given (, and when (
3093              
3094             # given, when
3095              
3096             # P.225 The given Statement
3097             # in Chapter 15: Smart Matching and given-when
3098             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3099              
3100             # P.133 The given Statement
3101             # in Chapter 4: Statements and Declarations
3102             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3103 18039         53845  
3104 1401         2040 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3105             $slash = 'm//';
3106             return $1;
3107             }
3108              
3109             # scalar variable ($scalar = ...) =~ tr///;
3110             # scalar variable ($scalar = ...) =~ s///;
3111              
3112             # state
3113              
3114             # P.68 Persistent, Private Variables
3115             # in Chapter 4: Subroutines
3116             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3117              
3118             # P.160 Persistent Lexically Scoped Variables: state
3119             # in Chapter 4: Statements and Declarations
3120             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3121              
3122             # (and so on)
3123 1401         4045  
3124             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3125 86 50       182 my $e_string = e_string($1);
    50          
3126 86         2001  
3127 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3128 0         0 $tr_variable = $e_string . e_string($1);
3129 0         0 $bind_operator = $2;
3130             $slash = 'm//';
3131             return '';
3132 0         0 }
3133 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3134 0         0 $sub_variable = $e_string . e_string($1);
3135 0         0 $bind_operator = $2;
3136             $slash = 'm//';
3137             return '';
3138 0         0 }
3139 86         153 else {
3140             $slash = 'div';
3141             return $e_string;
3142             }
3143             }
3144              
3145 86         271 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
3146 4         7 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3147             $slash = 'div';
3148             return q{Elatin10::PREMATCH()};
3149             }
3150              
3151 4         13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
3152 28         52 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3153             $slash = 'div';
3154             return q{Elatin10::MATCH()};
3155             }
3156              
3157 28         86 # $', ${'} --> $', ${'}
3158 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3159             $slash = 'div';
3160             return $1;
3161             }
3162              
3163 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
3164 3         4 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3165             $slash = 'div';
3166             return q{Elatin10::POSTMATCH()};
3167             }
3168              
3169             # scalar variable $scalar =~ tr///;
3170             # scalar variable $scalar =~ s///;
3171             # substr() =~ tr///;
3172 3         10 # substr() =~ s///;
3173             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3174 1671 100       3594 my $scalar = e_string($1);
    100          
3175 1671         6662  
3176 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3177 1         3 $tr_variable = $scalar;
3178 1         2 $bind_operator = $1;
3179             $slash = 'm//';
3180             return '';
3181 1         3 }
3182 61         124 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3183 61         116 $sub_variable = $scalar;
3184 61         91 $bind_operator = $1;
3185             $slash = 'm//';
3186             return '';
3187 61         174 }
3188 1609         2186 else {
3189             $slash = 'div';
3190             return $scalar;
3191             }
3192             }
3193              
3194 1609         4299 # end of statement
3195             elsif (/\G ( [,;] ) /oxgc) {
3196             $slash = 'm//';
3197 5011         7139  
3198             # clear tr/// variable
3199             $tr_variable = '';
3200 5011         5989  
3201             # clear s/// variable
3202 5011         5536 $sub_variable = '';
3203              
3204 5011         5435 $bind_operator = '';
3205              
3206             return $1;
3207             }
3208              
3209 5011         17159 # bareword
3210             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3211             return $1;
3212             }
3213              
3214 0         0 # $0 --> $0
3215 2         4 elsif (/\G ( \$ 0 ) /oxmsgc) {
3216             $slash = 'div';
3217             return $1;
3218 2         8 }
3219 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3220             $slash = 'div';
3221             return $1;
3222             }
3223              
3224 0         0 # $$ --> $$
3225 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3226             $slash = 'div';
3227             return $1;
3228             }
3229              
3230             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3231 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3232 4         7 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3233             $slash = 'div';
3234             return e_capture($1);
3235 4         5 }
3236 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3237             $slash = 'div';
3238             return e_capture($1);
3239             }
3240              
3241 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3242 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3243             $slash = 'div';
3244             return e_capture($1.'->'.$2);
3245             }
3246              
3247 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3248 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3249             $slash = 'div';
3250             return e_capture($1.'->'.$2);
3251             }
3252              
3253 0         0 # $$foo
3254 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3255             $slash = 'div';
3256             return e_capture($1);
3257             }
3258              
3259 0         0 # ${ foo }
3260 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3261             $slash = 'div';
3262             return '${' . $1 . '}';
3263             }
3264              
3265 0         0 # ${ ... }
3266 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3267             $slash = 'div';
3268             return e_capture($1);
3269             }
3270              
3271             # variable or function
3272 0         0 # $ @ % & * $ #
3273 42         66 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) {
3274             $slash = 'div';
3275             return $1;
3276             }
3277             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3278 42         132 # $ @ # \ ' " / ? ( ) [ ] < >
3279 62         108 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3280             $slash = 'div';
3281             return $1;
3282             }
3283              
3284 62         215 # while ()
3285             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3286             return $1;
3287             }
3288              
3289             # while () --- glob
3290              
3291             # avoid "Error: Runtime exception" of perl version 5.005_03
3292 0         0  
3293             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3294             return 'while ($_ = Elatin10::glob("' . $1 . '"))';
3295             }
3296              
3297 0         0 # while (glob)
3298             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3299             return 'while ($_ = Elatin10::glob_)';
3300             }
3301              
3302 0         0 # while (glob(WILDCARD))
3303             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3304             return 'while ($_ = Elatin10::glob';
3305             }
3306 0         0  
  248         555  
3307             # doit if, doit unless, doit while, doit until, doit for, doit when
3308             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3309 248         870  
  19         34  
3310 19         58 # subroutines of package Elatin10
  0         0  
3311 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         24  
3312 13         30 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3313 0         0 elsif (/\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         175  
3314 114         323 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         14  
3315 2         8 elsif (/\G \b Latin10::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin10::escape'; }
  0         0  
3316 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3317 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chop'; }
  0         0  
3318 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3319 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3320 0         0 elsif (/\G \b Latin10::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::index'; }
  2         4  
3321 2         7 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::index'; }
  0         0  
3322 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3323 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3324 0         0 elsif (/\G \b Latin10::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::rindex'; }
  1         3  
3325 1         5 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::rindex'; }
  0         0  
3326 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lc'; }
  1         3  
3327 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst'; }
  0         0  
3328 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::uc'; }
  6         9  
3329             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst'; }
3330             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::fc'; }
3331 6         16  
  0         0  
3332 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3333 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3334 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3335 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3336 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3337 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3338             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3339 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  
3340 0         0  
  0         0  
3341 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3342 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3343 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3344 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3345 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3346             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3347             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3348 0         0  
  0         0  
3349 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3350 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3351 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3352             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3353 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3354 2         7  
  2         4  
3355 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         77  
3356 36         110 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3357 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::chr'; }
  8         14  
3358 8         24 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3359 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3360 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::glob'; }
  0         0  
3361 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lc_'; }
  0         0  
3362 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst_'; }
  0         0  
3363 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::uc_'; }
  0         0  
3364 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst_'; }
  0         0  
3365             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::fc_'; }
3366 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3367 0         0  
  0         0  
3368 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3369 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3370 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chr_'; }
  0         0  
3371 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3372 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3373 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::glob_'; }
  8         21  
3374             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3375             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3376 8         28 # split
3377             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3378 87         182 $slash = 'm//';
3379 87         132  
3380 87         352 my $e = '';
3381             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3382             $e .= $1;
3383             }
3384 85 100       350  
  87 100       5598  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3385             # end of split
3386             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
3387 2         8  
3388             # split scalar value
3389             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin10::split' . $e . e_string($1); }
3390 1         4  
3391 0         0 # split literal space
3392 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {qq$1 $2}; }
3393 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3394 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3395 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3396 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3397 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3398 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {q$1 $2}; }
3399 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3400 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3401 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3402 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3403 10         41 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3404             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin10::split' . $e . qq {' '}; }
3405             elsif (/\G " [ ] " /oxgc) { return 'Elatin10::split' . $e . qq {" "}; }
3406              
3407 0 0       0 # split qq//
  0         0  
3408             elsif (/\G \b (qq) \b /oxgc) {
3409 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3410 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3411 0         0 while (not /\G \z/oxgc) {
3412 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3413 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3414 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3415 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3416 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3417             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3418 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3419             }
3420             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3421             }
3422             }
3423              
3424 0 50       0 # split qr//
  12         399  
3425             elsif (/\G \b (qr) \b /oxgc) {
3426 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3427 12 50       60 else {
  12 50       3101  
    50          
    50          
    50          
    50          
    50          
    50          
3428 0         0 while (not /\G \z/oxgc) {
3429 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3430 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3431 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3432 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3433 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3434 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3435             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3436 12         79 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3437             }
3438             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3439             }
3440             }
3441              
3442 0 0       0 # split q//
  0         0  
3443             elsif (/\G \b (q) \b /oxgc) {
3444 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3445 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3446 0         0 while (not /\G \z/oxgc) {
3447 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3448 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3449 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3450 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3451 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3452             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3453 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3454             }
3455             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3456             }
3457             }
3458              
3459 0 50       0 # split m//
  18         449  
3460             elsif (/\G \b (m) \b /oxgc) {
3461 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3462 18 50       80 else {
  18 50       3637  
    50          
    50          
    50          
    50          
    50          
    50          
3463 0         0 while (not /\G \z/oxgc) {
3464 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3465 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3466 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3467 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3468 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3469 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3470             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3471 18         109 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3472             }
3473             die __FILE__, ": Search pattern not terminated\n";
3474             }
3475             }
3476              
3477 0         0 # split ''
3478 0         0 elsif (/\G (\') /oxgc) {
3479 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3480 0         0 while (not /\G \z/oxgc) {
3481 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3482 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3483             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3484 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3485             }
3486             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3487             }
3488              
3489 0         0 # split ""
3490 0         0 elsif (/\G (\") /oxgc) {
3491 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3492 0         0 while (not /\G \z/oxgc) {
3493 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3494 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3495             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3496 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3497             }
3498             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3499             }
3500              
3501 0         0 # split //
3502 44         165 elsif (/\G (\/) /oxgc) {
3503 44 50       154 my $regexp = '';
  381 50       1604  
    100          
    50          
3504 0         0 while (not /\G \z/oxgc) {
3505 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3506 44         185 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3507             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3508 337         704 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3509             }
3510             die __FILE__, ": Search pattern not terminated\n";
3511             }
3512             }
3513              
3514             # tr/// or y///
3515              
3516             # about [cdsrbB]* (/B modifier)
3517             #
3518             # P.559 appendix C
3519             # of ISBN 4-89052-384-7 Programming perl
3520             # (Japanese title is: Perl puroguramingu)
3521 0         0  
3522             elsif (/\G \b ( tr | y ) \b /oxgc) {
3523             my $ope = $1;
3524 3 50       8  
3525 3         39 # $1 $2 $3 $4 $5 $6
3526 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3527             my @tr = ($tr_variable,$2);
3528             return e_tr(@tr,'',$4,$6);
3529 0         0 }
3530 3         5 else {
3531 3 50       10 my $e = '';
  3 50       256  
    50          
    50          
    50          
    50          
3532             while (not /\G \z/oxgc) {
3533 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3534 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3535 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3536 0         0 while (not /\G \z/oxgc) {
3537 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3538 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3539 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3540 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3541             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3542 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3543             }
3544             die __FILE__, ": Transliteration replacement not terminated\n";
3545 0         0 }
3546 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3547 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3548 0         0 while (not /\G \z/oxgc) {
3549 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3550 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3551 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3552 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3553             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3554 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3555             }
3556             die __FILE__, ": Transliteration replacement not terminated\n";
3557 0         0 }
3558 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3559 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3560 0         0 while (not /\G \z/oxgc) {
3561 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3562 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3563 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3564 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3565             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3566 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3567             }
3568             die __FILE__, ": Transliteration replacement not terminated\n";
3569 0         0 }
3570 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3571 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3572 0         0 while (not /\G \z/oxgc) {
3573 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3574 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3575 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3576 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3577             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3578 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3579             }
3580             die __FILE__, ": Transliteration replacement not terminated\n";
3581             }
3582 0         0 # $1 $2 $3 $4 $5 $6
3583 3         14 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3584             my @tr = ($tr_variable,$2);
3585             return e_tr(@tr,'',$4,$6);
3586 3         8 }
3587             }
3588             die __FILE__, ": Transliteration pattern not terminated\n";
3589             }
3590             }
3591              
3592 0         0 # qq//
3593             elsif (/\G \b (qq) \b /oxgc) {
3594             my $ope = $1;
3595 2180 50       4625  
3596 2180         3920 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3597 0         0 if (/\G (\#) /oxgc) { # qq# #
3598 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3599 0         0 while (not /\G \z/oxgc) {
3600 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3601 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3602             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3603 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3604             }
3605             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3606             }
3607 0         0  
3608 2180         4064 else {
3609 2180 50       5290 my $e = '';
  2180 50       8046  
    100          
    50          
    50          
    0          
3610             while (not /\G \z/oxgc) {
3611             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3612              
3613 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3614 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3615 0         0 my $qq_string = '';
3616 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3617 0         0 while (not /\G \z/oxgc) {
3618 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3619             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3620 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3621 0         0 elsif (/\G (\)) /oxgc) {
3622             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3623 0         0 else { $qq_string .= $1; }
3624             }
3625 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3626             }
3627             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3628             }
3629              
3630 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3631 2150         2758 elsif (/\G (\{) /oxgc) { # qq { }
3632 2150         2893 my $qq_string = '';
3633 2150 100       4312 local $nest = 1;
  84019 50       274155  
    100          
    100          
    50          
3634 722         1340 while (not /\G \z/oxgc) {
3635 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1696  
3636             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3637 1153 100       1931 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5906  
3638 2150         4325 elsif (/\G (\}) /oxgc) {
3639             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3640 1153         2190 else { $qq_string .= $1; }
3641             }
3642 78841         154005 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3643             }
3644             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3645             }
3646              
3647 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3648 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3649 0         0 my $qq_string = '';
3650 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3651 0         0 while (not /\G \z/oxgc) {
3652 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3653             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3654 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3655 0         0 elsif (/\G (\]) /oxgc) {
3656             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3657 0         0 else { $qq_string .= $1; }
3658             }
3659 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3660             }
3661             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3662             }
3663              
3664 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3665 30         47 elsif (/\G (\<) /oxgc) { # qq < >
3666 30         51 my $qq_string = '';
3667 30 100       91 local $nest = 1;
  1166 50       4349  
    50          
    100          
    50          
3668 22         49 while (not /\G \z/oxgc) {
3669 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3670             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3671 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         66  
3672 30         1846 elsif (/\G (\>) /oxgc) {
3673             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3674 0         0 else { $qq_string .= $1; }
3675             }
3676 1114         2216 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3677             }
3678             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3679             }
3680              
3681 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3682 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3683 0         0 my $delimiter = $1;
3684 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3685 0         0 while (not /\G \z/oxgc) {
3686 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3687 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3688             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3689 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3690             }
3691             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3692 0         0 }
3693             }
3694             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3695             }
3696             }
3697              
3698 0         0 # qr//
3699 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3700 0         0 my $ope = $1;
3701             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3702             return e_qr($ope,$1,$3,$2,$4);
3703 0         0 }
3704 0         0 else {
3705 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3706 0         0 while (not /\G \z/oxgc) {
3707 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3708 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3709 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3710 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3711 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3712 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3713             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3714 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3715             }
3716             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3717             }
3718             }
3719              
3720 0         0 # qw//
3721 16 50       41 elsif (/\G \b (qw) \b /oxgc) {
3722 16         55 my $ope = $1;
3723             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3724             return e_qw($ope,$1,$3,$2);
3725 0         0 }
3726 16         41 else {
3727 16 50       53 my $e = '';
  16 50       116  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3728             while (not /\G \z/oxgc) {
3729 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3730 16         77  
3731             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3732 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3733 0         0  
3734             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3735 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3736 0         0  
3737             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3738 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3739 0         0  
3740             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3741 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3742 0         0  
3743             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3744 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3745             }
3746             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3747             }
3748             }
3749              
3750 0         0 # qx//
3751 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3752 0         0 my $ope = $1;
3753             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3754             return e_qq($ope,$1,$3,$2);
3755 0         0 }
3756 0         0 else {
3757 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3758 0         0 while (not /\G \z/oxgc) {
3759 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3760 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3761 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3762 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3763 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3764             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3765 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3766             }
3767             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3768             }
3769             }
3770              
3771 0         0 # q//
3772             elsif (/\G \b (q) \b /oxgc) {
3773             my $ope = $1;
3774              
3775             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3776              
3777             # avoid "Error: Runtime exception" of perl version 5.005_03
3778 410 50       1119 # (and so on)
3779 410         1320  
3780 0         0 if (/\G (\#) /oxgc) { # q# #
3781 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3782 0         0 while (not /\G \z/oxgc) {
3783 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3784 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3785             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3786 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3787             }
3788             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3789             }
3790 0         0  
3791 410         658 else {
3792 410 50       1268 my $e = '';
  410 50       2332  
    100          
    50          
    100          
    50          
3793             while (not /\G \z/oxgc) {
3794             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3795              
3796 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3797 0         0 elsif (/\G (\() /oxgc) { # q ( )
3798 0         0 my $q_string = '';
3799 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3800 0         0 while (not /\G \z/oxgc) {
3801 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3802 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3803             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3804 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3805 0         0 elsif (/\G (\)) /oxgc) {
3806             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3807 0         0 else { $q_string .= $1; }
3808             }
3809 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3810             }
3811             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3812             }
3813              
3814 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3815 404         650 elsif (/\G (\{) /oxgc) { # q { }
3816 404         668 my $q_string = '';
3817 404 50       1075 local $nest = 1;
  6783 50       25378  
    50          
    100          
    100          
    50          
3818 0         0 while (not /\G \z/oxgc) {
3819 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3820 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         165  
3821             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3822 107 100       187 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1107  
3823 404         1039 elsif (/\G (\}) /oxgc) {
3824             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3825 107         1288 else { $q_string .= $1; }
3826             }
3827 6165         12186 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3828             }
3829             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3830             }
3831              
3832 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3833 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3834 0         0 my $q_string = '';
3835 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3836 0         0 while (not /\G \z/oxgc) {
3837 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3838 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3839             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3840 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3841 0         0 elsif (/\G (\]) /oxgc) {
3842             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3843 0         0 else { $q_string .= $1; }
3844             }
3845 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3846             }
3847             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3848             }
3849              
3850 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3851 5         11 elsif (/\G (\<) /oxgc) { # q < >
3852 5         10 my $q_string = '';
3853 5 50       29 local $nest = 1;
  88 50       371  
    50          
    50          
    100          
    50          
3854 0         0 while (not /\G \z/oxgc) {
3855 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3856 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3857             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3858 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         15  
3859 5         12 elsif (/\G (\>) /oxgc) {
3860             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3861 0         0 else { $q_string .= $1; }
3862             }
3863 83         159 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3864             }
3865             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3866             }
3867              
3868 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3869 1         3 elsif (/\G (\S) /oxgc) { # q * *
3870 1         2 my $delimiter = $1;
3871 1 50       5 my $q_string = '';
  14 50       73  
    100          
    50          
3872 0         0 while (not /\G \z/oxgc) {
3873 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3874 1         4 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3875             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3876 13         25 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3877             }
3878             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3879 0         0 }
3880             }
3881             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3882             }
3883             }
3884              
3885 0         0 # m//
3886 209 50       483 elsif (/\G \b (m) \b /oxgc) {
3887 209         1399 my $ope = $1;
3888             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3889             return e_qr($ope,$1,$3,$2,$4);
3890 0         0 }
3891 209         330 else {
3892 209 50       519 my $e = '';
  209 50       10390  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3893 0         0 while (not /\G \z/oxgc) {
3894 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3895 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3896 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3897 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3898 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3899 10         28 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3900 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3901             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3902 199         591 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3903             }
3904             die __FILE__, ": Search pattern not terminated\n";
3905             }
3906             }
3907              
3908             # s///
3909              
3910             # about [cegimosxpradlunbB]* (/cg modifier)
3911             #
3912             # P.67 Pattern-Matching Operators
3913             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3914 0         0  
3915             elsif (/\G \b (s) \b /oxgc) {
3916             my $ope = $1;
3917 97 100       249  
3918 97         1622 # $1 $2 $3 $4 $5 $6
3919             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3920             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3921 1         6 }
3922 96         206 else {
3923 96 50       299 my $e = '';
  96 50       27770  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3924             while (not /\G \z/oxgc) {
3925 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3926 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3927 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3928             while (not /\G \z/oxgc) {
3929 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3930 0         0 # $1 $2 $3 $4
3931 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940             }
3941             die __FILE__, ": Substitution replacement not terminated\n";
3942 0         0 }
3943 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3944 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3945             while (not /\G \z/oxgc) {
3946 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3947 0         0 # $1 $2 $3 $4
3948 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957             }
3958             die __FILE__, ": Substitution replacement not terminated\n";
3959 0         0 }
3960 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3961 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3962             while (not /\G \z/oxgc) {
3963 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3964 0         0 # $1 $2 $3 $4
3965 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972             }
3973             die __FILE__, ": Substitution replacement not terminated\n";
3974 0         0 }
3975 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3976 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3977             while (not /\G \z/oxgc) {
3978 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3979 0         0 # $1 $2 $3 $4
3980 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3985 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3986 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3987             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3988 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3989             }
3990             die __FILE__, ": Substitution replacement not terminated\n";
3991             }
3992 0         0 # $1 $2 $3 $4 $5 $6
3993             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3994             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3995             }
3996 21         54 # $1 $2 $3 $4 $5 $6
3997             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3998             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3999             }
4000 0         0 # $1 $2 $3 $4 $5 $6
4001             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4002             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4003             }
4004 0         0 # $1 $2 $3 $4 $5 $6
4005             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4006             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4007 75         326 }
4008             }
4009             die __FILE__, ": Substitution pattern not terminated\n";
4010             }
4011             }
4012 0         0  
4013 0         0 # require ignore module
4014 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4015             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4016             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4017 0         0  
4018 37         316 # use strict; --> use strict; no strict qw(refs);
4019 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4020             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4021             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4022              
4023 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4024 2         20 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4025             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4026             return "use $1; no strict qw(refs);";
4027 0         0 }
4028             else {
4029             return "use $1;";
4030             }
4031 2 0 0     11 }
      0        
4032 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4033             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4034             return "use $1; no strict qw(refs);";
4035 0         0 }
4036             else {
4037             return "use $1;";
4038             }
4039             }
4040 0         0  
4041 2         15 # ignore use module
4042 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4043             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4044             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4045 0         0  
4046 0         0 # ignore no module
4047 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4048             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4049             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4050 0         0  
4051             # use else
4052             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4053 0         0  
4054             # use else
4055             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4056              
4057 2         9 # ''
4058 848         1636 elsif (/\G (?
4059 848 100       2144 my $q_string = '';
  8267 100       24201  
    100          
    50          
4060 4         12 while (not /\G \z/oxgc) {
4061 48         87 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4062 848         1904 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4063             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4064 7367         14015 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4065             }
4066             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4067             }
4068              
4069 0         0 # ""
4070 1830         3430 elsif (/\G (\") /oxgc) {
4071 1830 100       4228 my $qq_string = '';
  35512 100       99544  
    100          
    50          
4072 67         266 while (not /\G \z/oxgc) {
4073 12         25 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4074 1830         4014 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4075             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4076 33603         64881 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4077             }
4078             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4079             }
4080              
4081 0         0 # ``
4082 1         3 elsif (/\G (\`) /oxgc) {
4083 1 50       4 my $qx_string = '';
  19 50       66  
    100          
    50          
4084 0         0 while (not /\G \z/oxgc) {
4085 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4086 1         4 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4087             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4088 18         35 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4089             }
4090             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4091             }
4092              
4093 0         0 # // --- not divide operator (num / num), not defined-or
4094 453         1428 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4095 453 50       1170 my $regexp = '';
  4496 50       14491  
    100          
    50          
4096 0         0 while (not /\G \z/oxgc) {
4097 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4098 453         1541 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4099             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4100 4043         8338 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4101             }
4102             die __FILE__, ": Search pattern not terminated\n";
4103             }
4104              
4105 0         0 # ?? --- not conditional operator (condition ? then : else)
4106 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4107 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4108 0         0 while (not /\G \z/oxgc) {
4109 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4110 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4111             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4112 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4113             }
4114             die __FILE__, ": Search pattern not terminated\n";
4115             }
4116 0         0  
  0         0  
4117             # <<>> (a safer ARGV)
4118             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4119 0         0  
  0         0  
4120             # << (bit shift) --- not here document
4121             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4122              
4123 0         0 # <<~'HEREDOC'
4124 6         11 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4125 6         14 $slash = 'm//';
4126             my $here_quote = $1;
4127             my $delimiter = $2;
4128 6 50       12  
4129 6         13 # get here document
4130 6         20 if ($here_script eq '') {
4131             $here_script = CORE::substr $_, pos $_;
4132 6 50       28 $here_script =~ s/.*?\n//oxm;
4133 6         73 }
4134 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4135 6         8 my $heredoc = $1;
4136 6         45 my $indent = $2;
4137 6         16 $heredoc =~ s{^$indent}{}msg; # no /ox
4138             push @heredoc, $heredoc . qq{\n$delimiter\n};
4139             push @heredoc_delimiter, qq{\\s*$delimiter};
4140 6         13 }
4141             else {
4142 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4143             }
4144             return qq{<<'$delimiter'};
4145             }
4146              
4147             # <<~\HEREDOC
4148              
4149             # P.66 2.6.6. "Here" Documents
4150             # in Chapter 2: Bits and Pieces
4151             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4152              
4153             # P.73 "Here" Documents
4154             # in Chapter 2: Bits and Pieces
4155             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4156 6         20  
4157 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4158 3         8 $slash = 'm//';
4159             my $here_quote = $1;
4160             my $delimiter = $2;
4161 3 50       6  
4162 3         8 # get here document
4163 3         13 if ($here_script eq '') {
4164             $here_script = CORE::substr $_, pos $_;
4165 3 50       24 $here_script =~ s/.*?\n//oxm;
4166 3         41 }
4167 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4168 3         4 my $heredoc = $1;
4169 3         45 my $indent = $2;
4170 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
4171             push @heredoc, $heredoc . qq{\n$delimiter\n};
4172             push @heredoc_delimiter, qq{\\s*$delimiter};
4173 3         15 }
4174             else {
4175 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4176             }
4177             return qq{<<\\$delimiter};
4178             }
4179              
4180 3         14 # <<~"HEREDOC"
4181 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4182 6         12 $slash = 'm//';
4183             my $here_quote = $1;
4184             my $delimiter = $2;
4185 6 50       16  
4186 6         14 # get here document
4187 6         58 if ($here_script eq '') {
4188             $here_script = CORE::substr $_, pos $_;
4189 6 50       35 $here_script =~ s/.*?\n//oxm;
4190 6         63 }
4191 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4192 6         8 my $heredoc = $1;
4193 6         47 my $indent = $2;
4194 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4195             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4196             push @heredoc_delimiter, qq{\\s*$delimiter};
4197 6         27 }
4198             else {
4199 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4200             }
4201             return qq{<<"$delimiter"};
4202             }
4203              
4204 6         27 # <<~HEREDOC
4205 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4206 3         6 $slash = 'm//';
4207             my $here_quote = $1;
4208             my $delimiter = $2;
4209 3 50       6  
4210 3         7 # get here document
4211 3         18 if ($here_script eq '') {
4212             $here_script = CORE::substr $_, pos $_;
4213 3 50       18 $here_script =~ s/.*?\n//oxm;
4214 3         46 }
4215 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4216 3         6 my $heredoc = $1;
4217 3         37 my $indent = $2;
4218 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4219             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4220             push @heredoc_delimiter, qq{\\s*$delimiter};
4221 3         7 }
4222             else {
4223 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4224             }
4225             return qq{<<$delimiter};
4226             }
4227              
4228 3         16 # <<~`HEREDOC`
4229 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4230 6         11 $slash = 'm//';
4231             my $here_quote = $1;
4232             my $delimiter = $2;
4233 6 50       9  
4234 6         14 # get here document
4235 6         16 if ($here_script eq '') {
4236             $here_script = CORE::substr $_, pos $_;
4237 6 50       38 $here_script =~ s/.*?\n//oxm;
4238 6         55 }
4239 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4240 6         8 my $heredoc = $1;
4241 6         47 my $indent = $2;
4242 6         15 $heredoc =~ s{^$indent}{}msg; # no /ox
4243             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4244             push @heredoc_delimiter, qq{\\s*$delimiter};
4245 6         20 }
4246             else {
4247 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4248             }
4249             return qq{<<`$delimiter`};
4250             }
4251              
4252 6         24 # <<'HEREDOC'
4253 72         150 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4254 72         149 $slash = 'm//';
4255             my $here_quote = $1;
4256             my $delimiter = $2;
4257 72 50       116  
4258 72         145 # get here document
4259 72         460 if ($here_script eq '') {
4260             $here_script = CORE::substr $_, pos $_;
4261 72 50       476 $here_script =~ s/.*?\n//oxm;
4262 72         568 }
4263 72         251 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4264             push @heredoc, $1 . qq{\n$delimiter\n};
4265             push @heredoc_delimiter, $delimiter;
4266 72         113 }
4267             else {
4268 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4269             }
4270             return $here_quote;
4271             }
4272              
4273             # <<\HEREDOC
4274              
4275             # P.66 2.6.6. "Here" Documents
4276             # in Chapter 2: Bits and Pieces
4277             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4278              
4279             # P.73 "Here" Documents
4280             # in Chapter 2: Bits and Pieces
4281             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4282 72         274  
4283 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4284 0         0 $slash = 'm//';
4285             my $here_quote = $1;
4286             my $delimiter = $2;
4287 0 0       0  
4288 0         0 # get here document
4289 0         0 if ($here_script eq '') {
4290             $here_script = CORE::substr $_, pos $_;
4291 0 0       0 $here_script =~ s/.*?\n//oxm;
4292 0         0 }
4293 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4294             push @heredoc, $1 . qq{\n$delimiter\n};
4295             push @heredoc_delimiter, $delimiter;
4296 0         0 }
4297             else {
4298 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4299             }
4300             return $here_quote;
4301             }
4302              
4303 0         0 # <<"HEREDOC"
4304 36         79 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4305 36         79 $slash = 'm//';
4306             my $here_quote = $1;
4307             my $delimiter = $2;
4308 36 50       79  
4309 36         81 # get here document
4310 36         250 if ($here_script eq '') {
4311             $here_script = CORE::substr $_, pos $_;
4312 36 50       208 $here_script =~ s/.*?\n//oxm;
4313 36         583 }
4314 36         115 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4315             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4316             push @heredoc_delimiter, $delimiter;
4317 36         80 }
4318             else {
4319 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4320             }
4321             return $here_quote;
4322             }
4323              
4324 36         155 # <
4325 42         102 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4326 42         95 $slash = 'm//';
4327             my $here_quote = $1;
4328             my $delimiter = $2;
4329 42 50       83  
4330 42         103 # get here document
4331 42         293 if ($here_script eq '') {
4332             $here_script = CORE::substr $_, pos $_;
4333 42 50       434 $here_script =~ s/.*?\n//oxm;
4334 42         535 }
4335 42         161 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4336             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4337             push @heredoc_delimiter, $delimiter;
4338 42         102 }
4339             else {
4340 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4341             }
4342             return $here_quote;
4343             }
4344              
4345 42         185 # <<`HEREDOC`
4346 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4347 0         0 $slash = 'm//';
4348             my $here_quote = $1;
4349             my $delimiter = $2;
4350 0 0       0  
4351 0         0 # get here document
4352 0         0 if ($here_script eq '') {
4353             $here_script = CORE::substr $_, pos $_;
4354 0 0       0 $here_script =~ s/.*?\n//oxm;
4355 0         0 }
4356 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4357             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4358             push @heredoc_delimiter, $delimiter;
4359 0         0 }
4360             else {
4361 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4362             }
4363             return $here_quote;
4364             }
4365              
4366 0         0 # <<= <=> <= < operator
4367             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4368             return $1;
4369             }
4370              
4371 12         65 #
4372             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4373             return $1;
4374             }
4375              
4376             # --- glob
4377              
4378             # avoid "Error: Runtime exception" of perl version 5.005_03
4379 0         0  
4380             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4381             return 'Elatin10::glob("' . $1 . '")';
4382             }
4383 0         0  
4384             # __DATA__
4385             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4386 0         0  
4387             # __END__
4388             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4389              
4390             # \cD Control-D
4391              
4392             # P.68 2.6.8. Other Literal Tokens
4393             # in Chapter 2: Bits and Pieces
4394             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4395              
4396             # P.76 Other Literal Tokens
4397             # in Chapter 2: Bits and Pieces
4398 204         1507 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4399              
4400             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4401 0         0  
4402             # \cZ Control-Z
4403             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4404              
4405             # any operator before div
4406             elsif (/\G (
4407             -- | \+\+ |
4408 0         0 [\)\}\]]
  5081         9762  
4409              
4410             ) /oxgc) { $slash = 'div'; return $1; }
4411              
4412             # yada-yada or triple-dot operator
4413             elsif (/\G (
4414 5081         22428 \.\.\.
  7         14  
4415              
4416             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4417              
4418             # any operator before m//
4419              
4420             # //, //= (defined-or)
4421              
4422             # P.164 Logical Operators
4423             # in Chapter 10: More Control Structures
4424             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4425              
4426             # P.119 C-Style Logical (Short-Circuit) Operators
4427             # in Chapter 3: Unary and Binary Operators
4428             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4429              
4430             # (and so on)
4431              
4432             # ~~
4433              
4434             # P.221 The Smart Match Operator
4435             # in Chapter 15: Smart Matching and given-when
4436             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4437              
4438             # P.112 Smartmatch Operator
4439             # in Chapter 3: Unary and Binary Operators
4440             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4441              
4442             # (and so on)
4443              
4444             elsif (/\G ((?>
4445              
4446             !~~ | !~ | != | ! |
4447             %= | % |
4448             &&= | && | &= | &\.= | &\. | & |
4449             -= | -> | - |
4450             :(?>\s*)= |
4451             : |
4452             <<>> |
4453             <<= | <=> | <= | < |
4454             == | => | =~ | = |
4455             >>= | >> | >= | > |
4456             \*\*= | \*\* | \*= | \* |
4457             \+= | \+ |
4458             \.\. | \.= | \. |
4459             \/\/= | \/\/ |
4460             \/= | \/ |
4461             \? |
4462             \\ |
4463             \^= | \^\.= | \^\. | \^ |
4464             \b x= |
4465             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4466             ~~ | ~\. | ~ |
4467             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4468             \b(?: print )\b |
4469              
4470 7         25 [,;\(\{\[]
  8859         16497  
4471              
4472             )) /oxgc) { $slash = 'm//'; return $1; }
4473 8859         38002  
  15261         27941  
4474             # other any character
4475             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4476              
4477 15261         65794 # system error
4478             else {
4479             die __FILE__, ": Oops, this shouldn't happen!\n";
4480             }
4481             }
4482              
4483 0     1786 0 0 # escape Latin-10 string
4484 1786         4319 sub e_string {
4485             my($string) = @_;
4486 1786         2599 my $e_string = '';
4487              
4488             local $slash = 'm//';
4489              
4490             # P.1024 Appendix W.10 Multibyte Processing
4491             # of ISBN 1-56592-224-7 CJKV Information Processing
4492 1786         2508 # (and so on)
4493              
4494             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4495 1786 100 66     13230  
4496 1786 50       7438 # without { ... }
4497 1769         4747 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4498             if ($string !~ /<
4499             return $string;
4500             }
4501             }
4502 1769         4261  
4503 17 50       60 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          
4504             while ($string !~ /\G \z/oxgc) {
4505             if (0) {
4506             }
4507 190         11478  
4508 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin10::PREMATCH()]}
4509 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4510             $e_string .= q{Elatin10::PREMATCH()};
4511             $slash = 'div';
4512             }
4513              
4514 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin10::MATCH()]}
4515 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4516             $e_string .= q{Elatin10::MATCH()};
4517             $slash = 'div';
4518             }
4519              
4520 0         0 # $', ${'} --> $', ${'}
4521 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4522             $e_string .= $1;
4523             $slash = 'div';
4524             }
4525              
4526 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin10::POSTMATCH()]}
4527 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4528             $e_string .= q{Elatin10::POSTMATCH()};
4529             $slash = 'div';
4530             }
4531              
4532 0         0 # bareword
4533 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4534             $e_string .= $1;
4535             $slash = 'div';
4536             }
4537              
4538 0         0 # $0 --> $0
4539 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4540             $e_string .= $1;
4541             $slash = 'div';
4542 0         0 }
4543 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4544             $e_string .= $1;
4545             $slash = 'div';
4546             }
4547              
4548 0         0 # $$ --> $$
4549 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4550             $e_string .= $1;
4551             $slash = 'div';
4552             }
4553              
4554             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4555 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4556 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4557             $e_string .= e_capture($1);
4558             $slash = 'div';
4559 0         0 }
4560 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4561             $e_string .= e_capture($1);
4562             $slash = 'div';
4563             }
4564              
4565 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4566 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4567             $e_string .= e_capture($1.'->'.$2);
4568             $slash = 'div';
4569             }
4570              
4571 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4572 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4573             $e_string .= e_capture($1.'->'.$2);
4574             $slash = 'div';
4575             }
4576              
4577 0         0 # $$foo
4578 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4579             $e_string .= e_capture($1);
4580             $slash = 'div';
4581             }
4582              
4583 0         0 # ${ foo }
4584 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4585             $e_string .= '${' . $1 . '}';
4586             $slash = 'div';
4587             }
4588              
4589 0         0 # ${ ... }
4590 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4591             $e_string .= e_capture($1);
4592             $slash = 'div';
4593             }
4594              
4595             # variable or function
4596 3         13 # $ @ % & * $ #
4597 7         23 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) {
4598             $e_string .= $1;
4599             $slash = 'div';
4600             }
4601             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4602 7         21 # $ @ # \ ' " / ? ( ) [ ] < >
4603 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4604             $e_string .= $1;
4605             $slash = 'div';
4606             }
4607 0         0  
  0         0  
4608 0         0 # subroutines of package Elatin10
  0         0  
4609 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4610 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4611 0         0 elsif ($string =~ /\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4612 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4613 0         0 elsif ($string =~ /\G \b Latin10::eval \b /oxgc) { $e_string .= 'eval Latin10::escape'; $slash = 'm//'; }
  0         0  
4614 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4615 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin10::chop'; $slash = 'm//'; }
  0         0  
4616 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4617 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4618 0         0 elsif ($string =~ /\G \b Latin10::index \b /oxgc) { $e_string .= 'Latin10::index'; $slash = 'm//'; }
  0         0  
4619 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin10::index'; $slash = 'm//'; }
  0         0  
4620 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4621 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4622 0         0 elsif ($string =~ /\G \b Latin10::rindex \b /oxgc) { $e_string .= 'Latin10::rindex'; $slash = 'm//'; }
  0         0  
4623 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin10::rindex'; $slash = 'm//'; }
  0         0  
4624 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lc'; $slash = 'm//'; }
  0         0  
4625 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lcfirst'; $slash = 'm//'; }
  0         0  
4626 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::uc'; $slash = 'm//'; }
  0         0  
4627             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::ucfirst'; $slash = 'm//'; }
4628             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::fc'; $slash = 'm//'; }
4629 0         0  
  0         0  
4630 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4631 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4632 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  
4633 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  
4634 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  
4635 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  
4636             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4637 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  
4638 0         0  
  0         0  
4639 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4640 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  
4641 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  
4642 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  
4643 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  
4644             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4645             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4646 0         0  
  0         0  
4647 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4648 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4649 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4650             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4651 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4652 0         0  
  0         0  
4653 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4654 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4655 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::chr'; $slash = 'm//'; }
  0         0  
4656 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4657 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4658 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::glob'; $slash = 'm//'; }
  0         0  
4659 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin10::lc_'; $slash = 'm//'; }
  0         0  
4660 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin10::lcfirst_'; $slash = 'm//'; }
  0         0  
4661 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin10::uc_'; $slash = 'm//'; }
  0         0  
4662 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin10::ucfirst_'; $slash = 'm//'; }
  0         0  
4663             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin10::fc_'; $slash = 'm//'; }
4664 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4665 0         0  
  0         0  
4666 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4667 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4668 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin10::chr_'; $slash = 'm//'; }
  0         0  
4669 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4670 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4671 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin10::glob_'; $slash = 'm//'; }
  0         0  
4672             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4673             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4674 0         0 # split
4675             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4676 0         0 $slash = 'm//';
4677 0         0  
4678 0         0 my $e = '';
4679             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4680             $e .= $1;
4681             }
4682 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4683             # end of split
4684             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
4685 0         0  
  0         0  
4686             # split scalar value
4687             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin10::split' . $e . e_string($1); next E_STRING_LOOP; }
4688 0         0  
  0         0  
4689 0         0 # split literal space
  0         0  
4690 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4691 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4692 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4693 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4694 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4695 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4696 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4697 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4698 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4699 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4700 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4701 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4702             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {' '}; next E_STRING_LOOP; }
4703             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {" "}; next E_STRING_LOOP; }
4704              
4705 0 0       0 # split qq//
  0         0  
  0         0  
4706             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4707 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4708 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4709 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4710 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4711 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  
4712 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  
4713 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  
4714 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  
4715             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4716 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 * *
4717             }
4718             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4719             }
4720             }
4721              
4722 0 0       0 # split qr//
  0         0  
  0         0  
4723             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4724 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4725 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4726 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4727 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4728 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  
4729 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  
4730 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  
4731 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  
4732 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  
4733             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4734 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 * *
4735             }
4736             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4737             }
4738             }
4739              
4740 0 0       0 # split q//
  0         0  
  0         0  
4741             elsif ($string =~ /\G \b (q) \b /oxgc) {
4742 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4743 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4744 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4745 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4746 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  
4747 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  
4748 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  
4749 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  
4750             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4751 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 * *
4752             }
4753             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4754             }
4755             }
4756              
4757 0 0       0 # split m//
  0         0  
  0         0  
4758             elsif ($string =~ /\G \b (m) \b /oxgc) {
4759 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 # #
4760 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4761 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4762 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4763 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  
4764 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  
4765 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  
4766 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  
4767 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  
4768             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4769 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 * *
4770             }
4771             die __FILE__, ": Search pattern not terminated\n";
4772             }
4773             }
4774              
4775 0         0 # split ''
4776 0         0 elsif ($string =~ /\G (\') /oxgc) {
4777 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4778 0         0 while ($string !~ /\G \z/oxgc) {
4779 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4780 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4781             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4782 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4783             }
4784             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4785             }
4786              
4787 0         0 # split ""
4788 0         0 elsif ($string =~ /\G (\") /oxgc) {
4789 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4790 0         0 while ($string !~ /\G \z/oxgc) {
4791 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4792 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4793             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4794 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4795             }
4796             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4797             }
4798              
4799 0         0 # split //
4800 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4801 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4802 0         0 while ($string !~ /\G \z/oxgc) {
4803 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4804 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4805             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4806 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4807             }
4808             die __FILE__, ": Search pattern not terminated\n";
4809             }
4810             }
4811              
4812 0         0 # qq//
4813 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4814 0         0 my $ope = $1;
4815             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4816             $e_string .= e_qq($ope,$1,$3,$2);
4817 0         0 }
4818 0         0 else {
4819 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4820 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4821 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4822 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4823 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4824 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4825             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4826 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4827             }
4828             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4829             }
4830             }
4831              
4832 0         0 # qx//
4833 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4834 0         0 my $ope = $1;
4835             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4836             $e_string .= e_qq($ope,$1,$3,$2);
4837 0         0 }
4838 0         0 else {
4839 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4840 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4841 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4842 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4843 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4844 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4845 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4846             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4847 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4848             }
4849             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4850             }
4851             }
4852              
4853 0         0 # q//
4854 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4855 0         0 my $ope = $1;
4856             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4857             $e_string .= e_q($ope,$1,$3,$2);
4858 0         0 }
4859 0         0 else {
4860 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4861 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4862 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4863 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4864 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4865 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4866             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4867 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 * *
4868             }
4869             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4870             }
4871             }
4872 0         0  
4873             # ''
4874             elsif ($string =~ /\G (?
4875 0         0  
4876             # ""
4877             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4878 0         0  
4879             # ``
4880             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4881 0         0  
4882             # <<>> (a safer ARGV)
4883             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4884 0         0  
4885             # <<= <=> <= < operator
4886             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4887 0         0  
4888             #
4889             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4890              
4891 0         0 # --- glob
4892             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4893             $e_string .= 'Elatin10::glob("' . $1 . '")';
4894             }
4895              
4896 0         0 # << (bit shift) --- not here document
4897 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4898             $slash = 'm//';
4899             $e_string .= $1;
4900             }
4901              
4902 0         0 # <<~'HEREDOC'
4903 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4904 0         0 $slash = 'm//';
4905             my $here_quote = $1;
4906             my $delimiter = $2;
4907 0 0       0  
4908 0         0 # get here document
4909 0         0 if ($here_script eq '') {
4910             $here_script = CORE::substr $_, pos $_;
4911 0 0       0 $here_script =~ s/.*?\n//oxm;
4912 0         0 }
4913 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4914 0         0 my $heredoc = $1;
4915 0         0 my $indent = $2;
4916 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4917             push @heredoc, $heredoc . qq{\n$delimiter\n};
4918             push @heredoc_delimiter, qq{\\s*$delimiter};
4919 0         0 }
4920             else {
4921 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4922             }
4923             $e_string .= qq{<<'$delimiter'};
4924             }
4925              
4926 0         0 # <<~\HEREDOC
4927 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4928 0         0 $slash = 'm//';
4929             my $here_quote = $1;
4930             my $delimiter = $2;
4931 0 0       0  
4932 0         0 # get here document
4933 0         0 if ($here_script eq '') {
4934             $here_script = CORE::substr $_, pos $_;
4935 0 0       0 $here_script =~ s/.*?\n//oxm;
4936 0         0 }
4937 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4938 0         0 my $heredoc = $1;
4939 0         0 my $indent = $2;
4940 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4941             push @heredoc, $heredoc . qq{\n$delimiter\n};
4942             push @heredoc_delimiter, qq{\\s*$delimiter};
4943 0         0 }
4944             else {
4945 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4946             }
4947             $e_string .= qq{<<\\$delimiter};
4948             }
4949              
4950 0         0 # <<~"HEREDOC"
4951 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4952 0         0 $slash = 'm//';
4953             my $here_quote = $1;
4954             my $delimiter = $2;
4955 0 0       0  
4956 0         0 # get here document
4957 0         0 if ($here_script eq '') {
4958             $here_script = CORE::substr $_, pos $_;
4959 0 0       0 $here_script =~ s/.*?\n//oxm;
4960 0         0 }
4961 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4962 0         0 my $heredoc = $1;
4963 0         0 my $indent = $2;
4964 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4965             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4966             push @heredoc_delimiter, qq{\\s*$delimiter};
4967 0         0 }
4968             else {
4969 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4970             }
4971             $e_string .= qq{<<"$delimiter"};
4972             }
4973              
4974 0         0 # <<~HEREDOC
4975 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4976 0         0 $slash = 'm//';
4977             my $here_quote = $1;
4978             my $delimiter = $2;
4979 0 0       0  
4980 0         0 # get here document
4981 0         0 if ($here_script eq '') {
4982             $here_script = CORE::substr $_, pos $_;
4983 0 0       0 $here_script =~ s/.*?\n//oxm;
4984 0         0 }
4985 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4986 0         0 my $heredoc = $1;
4987 0         0 my $indent = $2;
4988 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4989             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4990             push @heredoc_delimiter, qq{\\s*$delimiter};
4991 0         0 }
4992             else {
4993 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4994             }
4995             $e_string .= qq{<<$delimiter};
4996             }
4997              
4998 0         0 # <<~`HEREDOC`
4999 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
5000 0         0 $slash = 'm//';
5001             my $here_quote = $1;
5002             my $delimiter = $2;
5003 0 0       0  
5004 0         0 # get here document
5005 0         0 if ($here_script eq '') {
5006             $here_script = CORE::substr $_, pos $_;
5007 0 0       0 $here_script =~ s/.*?\n//oxm;
5008 0         0 }
5009 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5010 0         0 my $heredoc = $1;
5011 0         0 my $indent = $2;
5012 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5013             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5014             push @heredoc_delimiter, qq{\\s*$delimiter};
5015 0         0 }
5016             else {
5017 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5018             }
5019             $e_string .= qq{<<`$delimiter`};
5020             }
5021              
5022 0         0 # <<'HEREDOC'
5023 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5024 0         0 $slash = 'm//';
5025             my $here_quote = $1;
5026             my $delimiter = $2;
5027 0 0       0  
5028 0         0 # get here document
5029 0         0 if ($here_script eq '') {
5030             $here_script = CORE::substr $_, pos $_;
5031 0 0       0 $here_script =~ s/.*?\n//oxm;
5032 0         0 }
5033 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5034             push @heredoc, $1 . qq{\n$delimiter\n};
5035             push @heredoc_delimiter, $delimiter;
5036 0         0 }
5037             else {
5038 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5039             }
5040             $e_string .= $here_quote;
5041             }
5042              
5043 0         0 # <<\HEREDOC
5044 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5045 0         0 $slash = 'm//';
5046             my $here_quote = $1;
5047             my $delimiter = $2;
5048 0 0       0  
5049 0         0 # get here document
5050 0         0 if ($here_script eq '') {
5051             $here_script = CORE::substr $_, pos $_;
5052 0 0       0 $here_script =~ s/.*?\n//oxm;
5053 0         0 }
5054 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5055             push @heredoc, $1 . qq{\n$delimiter\n};
5056             push @heredoc_delimiter, $delimiter;
5057 0         0 }
5058             else {
5059 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5060             }
5061             $e_string .= $here_quote;
5062             }
5063              
5064 0         0 # <<"HEREDOC"
5065 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5066 0         0 $slash = 'm//';
5067             my $here_quote = $1;
5068             my $delimiter = $2;
5069 0 0       0  
5070 0         0 # get here document
5071 0         0 if ($here_script eq '') {
5072             $here_script = CORE::substr $_, pos $_;
5073 0 0       0 $here_script =~ s/.*?\n//oxm;
5074 0         0 }
5075 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5076             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5077             push @heredoc_delimiter, $delimiter;
5078 0         0 }
5079             else {
5080 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5081             }
5082             $e_string .= $here_quote;
5083             }
5084              
5085 0         0 # <
5086 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5087 0         0 $slash = 'm//';
5088             my $here_quote = $1;
5089             my $delimiter = $2;
5090 0 0       0  
5091 0         0 # get here document
5092 0         0 if ($here_script eq '') {
5093             $here_script = CORE::substr $_, pos $_;
5094 0 0       0 $here_script =~ s/.*?\n//oxm;
5095 0         0 }
5096 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5097             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5098             push @heredoc_delimiter, $delimiter;
5099 0         0 }
5100             else {
5101 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5102             }
5103             $e_string .= $here_quote;
5104             }
5105              
5106 0         0 # <<`HEREDOC`
5107 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5108 0         0 $slash = 'm//';
5109             my $here_quote = $1;
5110             my $delimiter = $2;
5111 0 0       0  
5112 0         0 # get here document
5113 0         0 if ($here_script eq '') {
5114             $here_script = CORE::substr $_, pos $_;
5115 0 0       0 $here_script =~ s/.*?\n//oxm;
5116 0         0 }
5117 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5118             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5119             push @heredoc_delimiter, $delimiter;
5120 0         0 }
5121             else {
5122 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5123             }
5124             $e_string .= $here_quote;
5125             }
5126              
5127             # any operator before div
5128             elsif ($string =~ /\G (
5129             -- | \+\+ |
5130 0         0 [\)\}\]]
  18         26  
5131              
5132             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5133              
5134             # yada-yada or triple-dot operator
5135             elsif ($string =~ /\G (
5136 18         54 \.\.\.
  0         0  
5137              
5138             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5139              
5140             # any operator before m//
5141             elsif ($string =~ /\G ((?>
5142              
5143             !~~ | !~ | != | ! |
5144             %= | % |
5145             &&= | && | &= | &\.= | &\. | & |
5146             -= | -> | - |
5147             :(?>\s*)= |
5148             : |
5149             <<>> |
5150             <<= | <=> | <= | < |
5151             == | => | =~ | = |
5152             >>= | >> | >= | > |
5153             \*\*= | \*\* | \*= | \* |
5154             \+= | \+ |
5155             \.\. | \.= | \. |
5156             \/\/= | \/\/ |
5157             \/= | \/ |
5158             \? |
5159             \\ |
5160             \^= | \^\.= | \^\. | \^ |
5161             \b x= |
5162             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5163             ~~ | ~\. | ~ |
5164             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5165             \b(?: print )\b |
5166              
5167 0         0 [,;\(\{\[]
  31         57  
5168              
5169             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5170 31         109  
5171             # other any character
5172             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5173              
5174 131         366 # system error
5175             else {
5176             die __FILE__, ": Oops, this shouldn't happen!\n";
5177             }
5178 0         0 }
5179              
5180             return $e_string;
5181             }
5182              
5183             #
5184             # character class
5185 17     1919 0 69 #
5186             sub character_class {
5187 1919 100       3301 my($char,$modifier) = @_;
5188 1919 100       3119  
5189 52         99 if ($char eq '.') {
5190             if ($modifier =~ /s/) {
5191             return '${Elatin10::dot_s}';
5192 17         39 }
5193             else {
5194             return '${Elatin10::dot}';
5195             }
5196 35         74 }
5197             else {
5198             return Elatin10::classic_character_class($char);
5199             }
5200             }
5201              
5202             #
5203             # escape capture ($1, $2, $3, ...)
5204             #
5205 1867     212 0 3045 sub e_capture {
5206              
5207             return join '', '${', $_[0], '}';
5208             }
5209              
5210             #
5211             # escape transliteration (tr/// or y///)
5212 212     3 0 762 #
5213 3         17 sub e_tr {
5214 3   50     4 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5215             my $e_tr = '';
5216 3         7 $modifier ||= '';
5217              
5218             $slash = 'div';
5219 3         5  
5220             # quote character class 1
5221             $charclass = q_tr($charclass);
5222 3         6  
5223             # quote character class 2
5224             $charclass2 = q_tr($charclass2);
5225 3 50       12  
5226 3 0       10 # /b /B modifier
5227 0         0 if ($modifier =~ tr/bB//d) {
5228             if ($variable eq '') {
5229             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5230 0         0 }
5231             else {
5232             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5233             }
5234 0 100       0 }
5235 3         8 else {
5236             if ($variable eq '') {
5237             $e_tr = qq{Elatin10::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5238 2         7 }
5239             else {
5240             $e_tr = qq{Elatin10::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5241             }
5242             }
5243 1         5  
5244 3         4 # clear tr/// variable
5245             $tr_variable = '';
5246 3         3 $bind_operator = '';
5247              
5248             return $e_tr;
5249             }
5250              
5251             #
5252             # quote for escape transliteration (tr/// or y///)
5253 3     6 0 17 #
5254             sub q_tr {
5255             my($charclass) = @_;
5256 6 50       12  
    0          
    0          
    0          
    0          
    0          
5257 6         11 # quote character class
5258             if ($charclass !~ /'/oxms) {
5259             return e_q('', "'", "'", $charclass); # --> q' '
5260 6         10 }
5261             elsif ($charclass !~ /\//oxms) {
5262             return e_q('q', '/', '/', $charclass); # --> q/ /
5263 0         0 }
5264             elsif ($charclass !~ /\#/oxms) {
5265             return e_q('q', '#', '#', $charclass); # --> q# #
5266 0         0 }
5267             elsif ($charclass !~ /[\<\>]/oxms) {
5268             return e_q('q', '<', '>', $charclass); # --> q< >
5269 0         0 }
5270             elsif ($charclass !~ /[\(\)]/oxms) {
5271             return e_q('q', '(', ')', $charclass); # --> q( )
5272 0         0 }
5273             elsif ($charclass !~ /[\{\}]/oxms) {
5274             return e_q('q', '{', '}', $charclass); # --> q{ }
5275 0         0 }
5276 0 0       0 else {
5277 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5278             if ($charclass !~ /\Q$char\E/xms) {
5279             return e_q('q', $char, $char, $charclass);
5280             }
5281             }
5282 0         0 }
5283              
5284             return e_q('q', '{', '}', $charclass);
5285             }
5286              
5287             #
5288             # escape q string (q//, '')
5289 0     1264 0 0 #
5290             sub e_q {
5291 1264         3062 my($ope,$delimiter,$end_delimiter,$string) = @_;
5292              
5293 1264         1767 $slash = 'div';
5294              
5295             return join '', $ope, $delimiter, $string, $end_delimiter;
5296             }
5297              
5298             #
5299             # escape qq string (qq//, "", qx//, ``)
5300 1264     4092 0 6146 #
5301             sub e_qq {
5302 4092         9094 my($ope,$delimiter,$end_delimiter,$string) = @_;
5303              
5304 4092         5235 $slash = 'div';
5305 4092         4647  
5306             my $left_e = 0;
5307             my $right_e = 0;
5308 4092         4925  
5309             # split regexp
5310             my @char = $string =~ /\G((?>
5311             [^\\\$] |
5312             \\x\{ (?>[0-9A-Fa-f]+) \} |
5313             \\o\{ (?>[0-7]+) \} |
5314             \\N\{ (?>[^0-9\}][^\}]*) \} |
5315             \\ $q_char |
5316             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5317             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5318             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5319             \$ (?>\s* [0-9]+) |
5320             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5321             \$ \$ (?![\w\{]) |
5322             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5323             $q_char
5324 4092         133404 ))/oxmsg;
5325              
5326             for (my $i=0; $i <= $#char; $i++) {
5327 4092 50 33     12807  
    50 33        
    100          
    100          
    50          
5328 114125         361269 # "\L\u" --> "\u\L"
5329             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5330             @char[$i,$i+1] = @char[$i+1,$i];
5331             }
5332              
5333 0         0 # "\U\l" --> "\l\U"
5334             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5335             @char[$i,$i+1] = @char[$i+1,$i];
5336             }
5337              
5338 0         0 # octal escape sequence
5339             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5340             $char[$i] = Elatin10::octchr($1);
5341             }
5342              
5343 1         4 # hexadecimal escape sequence
5344             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5345             $char[$i] = Elatin10::hexchr($1);
5346             }
5347              
5348 1         4 # \N{CHARNAME} --> N{CHARNAME}
5349             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5350             $char[$i] = $1;
5351 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          
5352              
5353             if (0) {
5354             }
5355              
5356             # \F
5357             #
5358             # P.69 Table 2-6. Translation escapes
5359             # in Chapter 2: Bits and Pieces
5360             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5361             # (and so on)
5362 114125         892639  
5363 0 50       0 # \u \l \U \L \F \Q \E
5364 484         1018 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5365             if ($right_e < $left_e) {
5366             $char[$i] = '\\' . $char[$i];
5367             }
5368             }
5369             elsif ($char[$i] eq '\u') {
5370              
5371             # "STRING @{[ LIST EXPR ]} MORE STRING"
5372              
5373             # P.257 Other Tricks You Can Do with Hard References
5374             # in Chapter 8: References
5375             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5376              
5377             # P.353 Other Tricks You Can Do with Hard References
5378             # in Chapter 8: References
5379             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5380              
5381 0         0 # (and so on)
5382 0         0  
5383             $char[$i] = '@{[Elatin10::ucfirst qq<';
5384             $left_e++;
5385 0         0 }
5386 0         0 elsif ($char[$i] eq '\l') {
5387             $char[$i] = '@{[Elatin10::lcfirst qq<';
5388             $left_e++;
5389 0         0 }
5390 0         0 elsif ($char[$i] eq '\U') {
5391             $char[$i] = '@{[Elatin10::uc qq<';
5392             $left_e++;
5393 0         0 }
5394 0         0 elsif ($char[$i] eq '\L') {
5395             $char[$i] = '@{[Elatin10::lc qq<';
5396             $left_e++;
5397 0         0 }
5398 24         35 elsif ($char[$i] eq '\F') {
5399             $char[$i] = '@{[Elatin10::fc qq<';
5400             $left_e++;
5401 24         66 }
5402 0         0 elsif ($char[$i] eq '\Q') {
5403             $char[$i] = '@{[CORE::quotemeta qq<';
5404             $left_e++;
5405 0 50       0 }
5406 24         33 elsif ($char[$i] eq '\E') {
5407 24         33 if ($right_e < $left_e) {
5408             $char[$i] = '>]}';
5409             $right_e++;
5410 24         37 }
5411             else {
5412             $char[$i] = '';
5413             }
5414 0         0 }
5415 0 0       0 elsif ($char[$i] eq '\Q') {
5416 0         0 while (1) {
5417             if (++$i > $#char) {
5418 0 0       0 last;
5419 0         0 }
5420             if ($char[$i] eq '\E') {
5421             last;
5422             }
5423             }
5424             }
5425             elsif ($char[$i] eq '\E') {
5426             }
5427              
5428             # $0 --> $0
5429             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5430             }
5431             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5432             }
5433              
5434             # $$ --> $$
5435             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5436             }
5437              
5438             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5439 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5440             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5441             $char[$i] = e_capture($1);
5442 205         387 }
5443             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5444             $char[$i] = e_capture($1);
5445             }
5446              
5447 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5448             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5449             $char[$i] = e_capture($1.'->'.$2);
5450             }
5451              
5452 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5453             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5454             $char[$i] = e_capture($1.'->'.$2);
5455             }
5456              
5457 0         0 # $$foo
5458             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5459             $char[$i] = e_capture($1);
5460             }
5461              
5462 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5463             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5464             $char[$i] = '@{[Elatin10::PREMATCH()]}';
5465             }
5466              
5467 44         112 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5468             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5469             $char[$i] = '@{[Elatin10::MATCH()]}';
5470             }
5471              
5472 45         192 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5473             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5474             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5475             }
5476              
5477             # ${ foo } --> ${ foo }
5478             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5479             }
5480              
5481 33         86 # ${ ... }
5482             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5483             $char[$i] = e_capture($1);
5484             }
5485             }
5486 0 50       0  
5487 4092         7369 # return string
5488             if ($left_e > $right_e) {
5489 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5490             }
5491             return join '', $ope, $delimiter, @char, $end_delimiter;
5492             }
5493              
5494             #
5495             # escape qw string (qw//)
5496 4092     16 0 31847 #
5497             sub e_qw {
5498 16         85 my($ope,$delimiter,$end_delimiter,$string) = @_;
5499              
5500             $slash = 'div';
5501 16         35  
  16         197  
5502 483 50       715 # choice again delimiter
    0          
    0          
    0          
    0          
5503 16         97 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5504             if (not $octet{$end_delimiter}) {
5505             return join '', $ope, $delimiter, $string, $end_delimiter;
5506 16         130 }
5507             elsif (not $octet{')'}) {
5508             return join '', $ope, '(', $string, ')';
5509 0         0 }
5510             elsif (not $octet{'}'}) {
5511             return join '', $ope, '{', $string, '}';
5512 0         0 }
5513             elsif (not $octet{']'}) {
5514             return join '', $ope, '[', $string, ']';
5515 0         0 }
5516             elsif (not $octet{'>'}) {
5517             return join '', $ope, '<', $string, '>';
5518 0         0 }
5519 0 0       0 else {
5520 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5521             if (not $octet{$char}) {
5522             return join '', $ope, $char, $string, $char;
5523             }
5524             }
5525             }
5526 0         0  
5527 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5528 0         0 my @string = CORE::split(/\s+/, $string);
5529 0         0 for my $string (@string) {
5530 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5531 0         0 for my $octet (@octet) {
5532             if ($octet =~ /\A (['\\]) \z/oxms) {
5533             $octet = '\\' . $1;
5534 0         0 }
5535             }
5536 0         0 $string = join '', @octet;
  0         0  
5537             }
5538             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5539             }
5540              
5541             #
5542             # escape here document (<<"HEREDOC", <
5543 0     93 0 0 #
5544             sub e_heredoc {
5545 93         2491 my($string) = @_;
5546              
5547 93         144 $slash = 'm//';
5548              
5549 93         349 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5550 93         151  
5551             my $left_e = 0;
5552             my $right_e = 0;
5553 93         134  
5554             # split regexp
5555             my @char = $string =~ /\G((?>
5556             [^\\\$] |
5557             \\x\{ (?>[0-9A-Fa-f]+) \} |
5558             \\o\{ (?>[0-7]+) \} |
5559             \\N\{ (?>[^0-9\}][^\}]*) \} |
5560             \\ $q_char |
5561             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5562             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5563             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5564             \$ (?>\s* [0-9]+) |
5565             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5566             \$ \$ (?![\w\{]) |
5567             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5568             $q_char
5569 93         9132 ))/oxmsg;
5570              
5571             for (my $i=0; $i <= $#char; $i++) {
5572 93 50 33     460  
    50 33        
    100          
    100          
    50          
5573 3203         10534 # "\L\u" --> "\u\L"
5574             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5575             @char[$i,$i+1] = @char[$i+1,$i];
5576             }
5577              
5578 0         0 # "\U\l" --> "\l\U"
5579             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5580             @char[$i,$i+1] = @char[$i+1,$i];
5581             }
5582              
5583 0         0 # octal escape sequence
5584             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5585             $char[$i] = Elatin10::octchr($1);
5586             }
5587              
5588 1         3 # hexadecimal escape sequence
5589             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5590             $char[$i] = Elatin10::hexchr($1);
5591             }
5592              
5593 1         3 # \N{CHARNAME} --> N{CHARNAME}
5594             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5595             $char[$i] = $1;
5596 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          
5597              
5598             if (0) {
5599             }
5600 3203         31309  
5601 0 0       0 # \u \l \U \L \F \Q \E
5602 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5603             if ($right_e < $left_e) {
5604             $char[$i] = '\\' . $char[$i];
5605             }
5606 0         0 }
5607 0         0 elsif ($char[$i] eq '\u') {
5608             $char[$i] = '@{[Elatin10::ucfirst qq<';
5609             $left_e++;
5610 0         0 }
5611 0         0 elsif ($char[$i] eq '\l') {
5612             $char[$i] = '@{[Elatin10::lcfirst qq<';
5613             $left_e++;
5614 0         0 }
5615 0         0 elsif ($char[$i] eq '\U') {
5616             $char[$i] = '@{[Elatin10::uc qq<';
5617             $left_e++;
5618 0         0 }
5619 0         0 elsif ($char[$i] eq '\L') {
5620             $char[$i] = '@{[Elatin10::lc qq<';
5621             $left_e++;
5622 0         0 }
5623 0         0 elsif ($char[$i] eq '\F') {
5624             $char[$i] = '@{[Elatin10::fc qq<';
5625             $left_e++;
5626 0         0 }
5627 0         0 elsif ($char[$i] eq '\Q') {
5628             $char[$i] = '@{[CORE::quotemeta qq<';
5629             $left_e++;
5630 0 0       0 }
5631 0         0 elsif ($char[$i] eq '\E') {
5632 0         0 if ($right_e < $left_e) {
5633             $char[$i] = '>]}';
5634             $right_e++;
5635 0         0 }
5636             else {
5637             $char[$i] = '';
5638             }
5639 0         0 }
5640 0 0       0 elsif ($char[$i] eq '\Q') {
5641 0         0 while (1) {
5642             if (++$i > $#char) {
5643 0 0       0 last;
5644 0         0 }
5645             if ($char[$i] eq '\E') {
5646             last;
5647             }
5648             }
5649             }
5650             elsif ($char[$i] eq '\E') {
5651             }
5652              
5653             # $0 --> $0
5654             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5655             }
5656             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5657             }
5658              
5659             # $$ --> $$
5660             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5661             }
5662              
5663             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5664 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5665             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5666             $char[$i] = e_capture($1);
5667 0         0 }
5668             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5669             $char[$i] = e_capture($1);
5670             }
5671              
5672 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5673             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5674             $char[$i] = e_capture($1.'->'.$2);
5675             }
5676              
5677 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5678             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5679             $char[$i] = e_capture($1.'->'.$2);
5680             }
5681              
5682 0         0 # $$foo
5683             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5684             $char[$i] = e_capture($1);
5685             }
5686              
5687 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5688             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5689             $char[$i] = '@{[Elatin10::PREMATCH()]}';
5690             }
5691              
5692 8         44 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5693             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5694             $char[$i] = '@{[Elatin10::MATCH()]}';
5695             }
5696              
5697 8         41 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5698             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5699             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5700             }
5701              
5702             # ${ foo } --> ${ foo }
5703             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5704             }
5705              
5706 6         30 # ${ ... }
5707             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5708             $char[$i] = e_capture($1);
5709             }
5710             }
5711 0 50       0  
5712 93         186 # return string
5713             if ($left_e > $right_e) {
5714 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5715             }
5716             return join '', @char;
5717             }
5718              
5719             #
5720             # escape regexp (m//, qr//)
5721 93     652 0 1869 #
5722 652   100     2596 sub e_qr {
5723             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5724 652         2592 $modifier ||= '';
5725 652 50       1106  
5726 652         1449 $modifier =~ tr/p//d;
5727 0         0 if ($modifier =~ /([adlu])/oxms) {
5728 0 0       0 my $line = 0;
5729 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5730 0         0 if ($filename ne __FILE__) {
5731             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5732             last;
5733 0         0 }
5734             }
5735             die qq{Unsupported modifier "$1" used at line $line.\n};
5736 0         0 }
5737              
5738             $slash = 'div';
5739 652 100       1025  
    100          
5740 652         1834 # literal null string pattern
5741 8         10 if ($string eq '') {
5742 8         10 $modifier =~ tr/bB//d;
5743             $modifier =~ tr/i//d;
5744             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5745             }
5746              
5747             # /b /B modifier
5748             elsif ($modifier =~ tr/bB//d) {
5749 8 50       35  
5750 2         6 # choice again delimiter
5751 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5752 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5753 0         0 my %octet = map {$_ => 1} @char;
5754 0         0 if (not $octet{')'}) {
5755             $delimiter = '(';
5756             $end_delimiter = ')';
5757 0         0 }
5758 0         0 elsif (not $octet{'}'}) {
5759             $delimiter = '{';
5760             $end_delimiter = '}';
5761 0         0 }
5762 0         0 elsif (not $octet{']'}) {
5763             $delimiter = '[';
5764             $end_delimiter = ']';
5765 0         0 }
5766 0         0 elsif (not $octet{'>'}) {
5767             $delimiter = '<';
5768             $end_delimiter = '>';
5769 0         0 }
5770 0 0       0 else {
5771 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5772 0         0 if (not $octet{$char}) {
5773 0         0 $delimiter = $char;
5774             $end_delimiter = $char;
5775             last;
5776             }
5777             }
5778             }
5779 0 50 33     0 }
5780 2         10  
5781             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5782             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5783 0         0 }
5784             else {
5785             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5786             }
5787 2 100       13 }
5788 642         1576  
5789             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5790             my $metachar = qr/[\@\\|[\]{^]/oxms;
5791 642         2257  
5792             # split regexp
5793             my @char = $string =~ /\G((?>
5794             [^\\\$\@\[\(] |
5795             \\x (?>[0-9A-Fa-f]{1,2}) |
5796             \\ (?>[0-7]{2,3}) |
5797             \\c [\x40-\x5F] |
5798             \\x\{ (?>[0-9A-Fa-f]+) \} |
5799             \\o\{ (?>[0-7]+) \} |
5800             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5801             \\ $q_char |
5802             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5803             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5804             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5805             [\$\@] $qq_variable |
5806             \$ (?>\s* [0-9]+) |
5807             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5808             \$ \$ (?![\w\{]) |
5809             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5810             \[\^ |
5811             \[\: (?>[a-z]+) :\] |
5812             \[\:\^ (?>[a-z]+) :\] |
5813             \(\? |
5814             $q_char
5815             ))/oxmsg;
5816 642 50       62222  
5817 642         2667 # choice again delimiter
  0         0  
5818 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5819 0         0 my %octet = map {$_ => 1} @char;
5820 0         0 if (not $octet{')'}) {
5821             $delimiter = '(';
5822             $end_delimiter = ')';
5823 0         0 }
5824 0         0 elsif (not $octet{'}'}) {
5825             $delimiter = '{';
5826             $end_delimiter = '}';
5827 0         0 }
5828 0         0 elsif (not $octet{']'}) {
5829             $delimiter = '[';
5830             $end_delimiter = ']';
5831 0         0 }
5832 0         0 elsif (not $octet{'>'}) {
5833             $delimiter = '<';
5834             $end_delimiter = '>';
5835 0         0 }
5836 0 0       0 else {
5837 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5838 0         0 if (not $octet{$char}) {
5839 0         0 $delimiter = $char;
5840             $end_delimiter = $char;
5841             last;
5842             }
5843             }
5844             }
5845 0         0 }
5846 642         1089  
5847 642         935 my $left_e = 0;
5848             my $right_e = 0;
5849             for (my $i=0; $i <= $#char; $i++) {
5850 642 50 66     1591  
    50 66        
    100          
    100          
    100          
    100          
5851 1872         9404 # "\L\u" --> "\u\L"
5852             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5853             @char[$i,$i+1] = @char[$i+1,$i];
5854             }
5855              
5856 0         0 # "\U\l" --> "\l\U"
5857             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5858             @char[$i,$i+1] = @char[$i+1,$i];
5859             }
5860              
5861 0         0 # octal escape sequence
5862             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5863             $char[$i] = Elatin10::octchr($1);
5864             }
5865              
5866 1         3 # hexadecimal escape sequence
5867             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5868             $char[$i] = Elatin10::hexchr($1);
5869             }
5870              
5871             # \b{...} --> b\{...}
5872             # \B{...} --> B\{...}
5873             # \N{CHARNAME} --> N\{CHARNAME}
5874             # \p{PROPERTY} --> p\{PROPERTY}
5875 1         15 # \P{PROPERTY} --> P\{PROPERTY}
5876             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5877             $char[$i] = $1 . '\\' . $2;
5878             }
5879              
5880 6         17 # \p, \P, \X --> p, P, X
5881             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5882             $char[$i] = $1;
5883 4 100 100     10 }
    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          
5884              
5885             if (0) {
5886             }
5887 1872         5190  
5888 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5889 6         92 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5890             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)) {
5891             $char[$i] .= join '', splice @char, $i+1, 3;
5892 0         0 }
5893             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)) {
5894             $char[$i] .= join '', splice @char, $i+1, 2;
5895 0         0 }
5896             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)) {
5897             $char[$i] .= join '', splice @char, $i+1, 1;
5898             }
5899             }
5900              
5901 0         0 # open character class [...]
5902             elsif ($char[$i] eq '[') {
5903             my $left = $i;
5904              
5905             # [] make die "Unmatched [] in regexp ...\n"
5906 328 100       427 # (and so on)
5907 328         747  
5908             if ($char[$i+1] eq ']') {
5909             $i++;
5910 3         5 }
5911 328 50       402  
5912 1379         2022 while (1) {
5913             if (++$i > $#char) {
5914 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5915 1379         2162 }
5916             if ($char[$i] eq ']') {
5917             my $right = $i;
5918 328 100       394  
5919 328         1600 # [...]
  30         72  
5920             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5921             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5922 90         155 }
5923             else {
5924             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5925 298         1074 }
5926 328         597  
5927             $i = $left;
5928             last;
5929             }
5930             }
5931             }
5932              
5933 328         804 # open character class [^...]
5934             elsif ($char[$i] eq '[^') {
5935             my $left = $i;
5936              
5937             # [^] make die "Unmatched [] in regexp ...\n"
5938 74 100       93 # (and so on)
5939 74         155  
5940             if ($char[$i+1] eq ']') {
5941             $i++;
5942 4         6 }
5943 74 50       87  
5944 272         394 while (1) {
5945             if (++$i > $#char) {
5946 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5947 272         393 }
5948             if ($char[$i] eq ']') {
5949             my $right = $i;
5950 74 100       93  
5951 74         343 # [^...]
  30         61  
5952             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5953             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5954 90         145 }
5955             else {
5956             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5957 44         145 }
5958 74         132  
5959             $i = $left;
5960             last;
5961             }
5962             }
5963             }
5964              
5965 74         176 # rewrite character class or escape character
5966             elsif (my $char = character_class($char[$i],$modifier)) {
5967             $char[$i] = $char;
5968             }
5969              
5970 139 50       348 # /i modifier
5971 20         34 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
5972             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
5973             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
5974 20         31 }
5975             else {
5976             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
5977             }
5978             }
5979              
5980 0 50       0 # \u \l \U \L \F \Q \E
5981 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5982             if ($right_e < $left_e) {
5983             $char[$i] = '\\' . $char[$i];
5984             }
5985 0         0 }
5986 0         0 elsif ($char[$i] eq '\u') {
5987             $char[$i] = '@{[Elatin10::ucfirst qq<';
5988             $left_e++;
5989 0         0 }
5990 0         0 elsif ($char[$i] eq '\l') {
5991             $char[$i] = '@{[Elatin10::lcfirst qq<';
5992             $left_e++;
5993 0         0 }
5994 1         2 elsif ($char[$i] eq '\U') {
5995             $char[$i] = '@{[Elatin10::uc qq<';
5996             $left_e++;
5997 1         2 }
5998 1         3 elsif ($char[$i] eq '\L') {
5999             $char[$i] = '@{[Elatin10::lc qq<';
6000             $left_e++;
6001 1         2 }
6002 18         27 elsif ($char[$i] eq '\F') {
6003             $char[$i] = '@{[Elatin10::fc qq<';
6004             $left_e++;
6005 18         36 }
6006 1         2 elsif ($char[$i] eq '\Q') {
6007             $char[$i] = '@{[CORE::quotemeta qq<';
6008             $left_e++;
6009 1 50       3 }
6010 21         39 elsif ($char[$i] eq '\E') {
6011 21         28 if ($right_e < $left_e) {
6012             $char[$i] = '>]}';
6013             $right_e++;
6014 21         43 }
6015             else {
6016             $char[$i] = '';
6017             }
6018 0         0 }
6019 0 0       0 elsif ($char[$i] eq '\Q') {
6020 0         0 while (1) {
6021             if (++$i > $#char) {
6022 0 0       0 last;
6023 0         0 }
6024             if ($char[$i] eq '\E') {
6025             last;
6026             }
6027             }
6028             }
6029             elsif ($char[$i] eq '\E') {
6030             }
6031              
6032 0 0       0 # $0 --> $0
6033 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6034             if ($ignorecase) {
6035             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6036             }
6037 0 0       0 }
6038 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6039             if ($ignorecase) {
6040             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6041             }
6042             }
6043              
6044             # $$ --> $$
6045             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6046             }
6047              
6048             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6049 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6050 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6051 0         0 $char[$i] = e_capture($1);
6052             if ($ignorecase) {
6053             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6054             }
6055 0         0 }
6056 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6057 0         0 $char[$i] = e_capture($1);
6058             if ($ignorecase) {
6059             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6060             }
6061             }
6062              
6063 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6064 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) {
6065 0         0 $char[$i] = e_capture($1.'->'.$2);
6066             if ($ignorecase) {
6067             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6068             }
6069             }
6070              
6071 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6072 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) {
6073 0         0 $char[$i] = e_capture($1.'->'.$2);
6074             if ($ignorecase) {
6075             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6076             }
6077             }
6078              
6079 0         0 # $$foo
6080 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6081 0         0 $char[$i] = e_capture($1);
6082             if ($ignorecase) {
6083             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6084             }
6085             }
6086              
6087 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
6088 8         23 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6089             if ($ignorecase) {
6090             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
6091 0         0 }
6092             else {
6093             $char[$i] = '@{[Elatin10::PREMATCH()]}';
6094             }
6095             }
6096              
6097 8 50       23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
6098 8         23 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6099             if ($ignorecase) {
6100             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
6101 0         0 }
6102             else {
6103             $char[$i] = '@{[Elatin10::MATCH()]}';
6104             }
6105             }
6106              
6107 8 50       22 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
6108 6         16 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6109             if ($ignorecase) {
6110             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
6111 0         0 }
6112             else {
6113             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
6114             }
6115             }
6116              
6117 6 0       17 # ${ foo }
6118 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) {
6119             if ($ignorecase) {
6120             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6121             }
6122             }
6123              
6124 0         0 # ${ ... }
6125 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6126 0         0 $char[$i] = e_capture($1);
6127             if ($ignorecase) {
6128             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6129             }
6130             }
6131              
6132 0         0 # $scalar or @array
6133 21 100       48 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6134 21         146 $char[$i] = e_string($char[$i]);
6135             if ($ignorecase) {
6136             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6137             }
6138             }
6139              
6140 11 100 33     32 # quote character before ? + * {
    50          
6141             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6142             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6143 138         911 }
6144 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6145 0         0 my $char = $char[$i-1];
6146             if ($char[$i] eq '{') {
6147             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6148 0         0 }
6149             else {
6150             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6151             }
6152 0         0 }
6153             else {
6154             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6155             }
6156             }
6157             }
6158 127         752  
6159 642 50       1308 # make regexp string
6160 642 0 0     1318 $modifier =~ tr/i//d;
6161 0         0 if ($left_e > $right_e) {
6162             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6163             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6164 0         0 }
6165             else {
6166             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6167 0 50 33     0 }
6168 642         3175 }
6169             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6170             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6171 0         0 }
6172             else {
6173             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6174             }
6175             }
6176              
6177             #
6178             # double quote stuff
6179 642     180 0 4983 #
6180             sub qq_stuff {
6181             my($delimiter,$end_delimiter,$stuff) = @_;
6182 180 100       257  
6183 180         380 # scalar variable or array variable
6184             if ($stuff =~ /\A [\$\@] /oxms) {
6185             return $stuff;
6186             }
6187 100         315  
  80         181  
6188 80         240 # quote by delimiter
6189 80 50       195 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6190 80 50       128 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6191 80 50       124 next if $char eq $delimiter;
6192 80         320 next if $char eq $end_delimiter;
6193             if (not $octet{$char}) {
6194             return join '', 'qq', $char, $stuff, $char;
6195 80         327 }
6196             }
6197             return join '', 'qq', '<', $stuff, '>';
6198             }
6199              
6200             #
6201             # escape regexp (m'', qr'', and m''b, qr''b)
6202 0     10 0 0 #
6203 10   50     38 sub e_qr_q {
6204             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6205 10         40 $modifier ||= '';
6206 10 50       13  
6207 10         19 $modifier =~ tr/p//d;
6208 0         0 if ($modifier =~ /([adlu])/oxms) {
6209 0 0       0 my $line = 0;
6210 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6211 0         0 if ($filename ne __FILE__) {
6212             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6213             last;
6214 0         0 }
6215             }
6216             die qq{Unsupported modifier "$1" used at line $line.\n};
6217 0         0 }
6218              
6219             $slash = 'div';
6220 10 100       13  
    50          
6221 10         23 # literal null string pattern
6222 8         9 if ($string eq '') {
6223 8         9 $modifier =~ tr/bB//d;
6224             $modifier =~ tr/i//d;
6225             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6226             }
6227              
6228 8         35 # with /b /B modifier
6229             elsif ($modifier =~ tr/bB//d) {
6230             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6231             }
6232              
6233 0         0 # without /b /B modifier
6234             else {
6235             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6236             }
6237             }
6238              
6239             #
6240             # escape regexp (m'', qr'')
6241 2     2 0 8 #
6242             sub e_qr_qt {
6243 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6244              
6245             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6246 2         5  
6247             # split regexp
6248             my @char = $string =~ /\G((?>
6249             [^\\\[\$\@\/] |
6250             [\x00-\xFF] |
6251             \[\^ |
6252             \[\: (?>[a-z]+) \:\] |
6253             \[\:\^ (?>[a-z]+) \:\] |
6254             [\$\@\/] |
6255             \\ (?:$q_char) |
6256             (?:$q_char)
6257             ))/oxmsg;
6258 2         59  
6259 2 50 33     11 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6260             for (my $i=0; $i <= $#char; $i++) {
6261             if (0) {
6262             }
6263 2         15  
6264 0         0 # open character class [...]
6265 0 0       0 elsif ($char[$i] eq '[') {
6266 0         0 my $left = $i;
6267             if ($char[$i+1] eq ']') {
6268 0         0 $i++;
6269 0 0       0 }
6270 0         0 while (1) {
6271             if (++$i > $#char) {
6272 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6273 0         0 }
6274             if ($char[$i] eq ']') {
6275             my $right = $i;
6276 0         0  
6277             # [...]
6278 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6279 0         0  
6280             $i = $left;
6281             last;
6282             }
6283             }
6284             }
6285              
6286 0         0 # open character class [^...]
6287 0 0       0 elsif ($char[$i] eq '[^') {
6288 0         0 my $left = $i;
6289             if ($char[$i+1] eq ']') {
6290 0         0 $i++;
6291 0 0       0 }
6292 0         0 while (1) {
6293             if (++$i > $#char) {
6294 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6295 0         0 }
6296             if ($char[$i] eq ']') {
6297             my $right = $i;
6298 0         0  
6299             # [^...]
6300 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6301 0         0  
6302             $i = $left;
6303             last;
6304             }
6305             }
6306             }
6307              
6308 0         0 # escape $ @ / and \
6309             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6310             $char[$i] = '\\' . $char[$i];
6311             }
6312              
6313 0         0 # rewrite character class or escape character
6314             elsif (my $char = character_class($char[$i],$modifier)) {
6315             $char[$i] = $char;
6316             }
6317              
6318 0 0       0 # /i modifier
6319 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6320             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6321             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6322 0         0 }
6323             else {
6324             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6325             }
6326             }
6327              
6328 0 0       0 # quote character before ? + * {
6329             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6330             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6331 0         0 }
6332             else {
6333             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6334             }
6335             }
6336 0         0 }
6337 2         5  
6338             $delimiter = '/';
6339 2         3 $end_delimiter = '/';
6340 2         3  
6341             $modifier =~ tr/i//d;
6342             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6343             }
6344              
6345             #
6346             # escape regexp (m''b, qr''b)
6347 2     0 0 13 #
6348             sub e_qr_qb {
6349             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6350 0         0  
6351             # split regexp
6352             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6353 0         0  
6354 0 0       0 # unescape character
    0          
6355             for (my $i=0; $i <= $#char; $i++) {
6356             if (0) {
6357             }
6358 0         0  
6359             # remain \\
6360             elsif ($char[$i] eq '\\\\') {
6361             }
6362              
6363 0         0 # escape $ @ / and \
6364             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6365             $char[$i] = '\\' . $char[$i];
6366             }
6367 0         0 }
6368 0         0  
6369 0         0 $delimiter = '/';
6370             $end_delimiter = '/';
6371             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6372             }
6373              
6374             #
6375             # escape regexp (s/here//)
6376 0     76 0 0 #
6377 76   100     227 sub e_s1 {
6378             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6379 76         330 $modifier ||= '';
6380 76 50       120  
6381 76         209 $modifier =~ tr/p//d;
6382 0         0 if ($modifier =~ /([adlu])/oxms) {
6383 0 0       0 my $line = 0;
6384 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6385 0         0 if ($filename ne __FILE__) {
6386             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6387             last;
6388 0         0 }
6389             }
6390             die qq{Unsupported modifier "$1" used at line $line.\n};
6391 0         0 }
6392              
6393             $slash = 'div';
6394 76 100       128  
    50          
6395 76         241 # literal null string pattern
6396 8         11 if ($string eq '') {
6397 8         9 $modifier =~ tr/bB//d;
6398             $modifier =~ tr/i//d;
6399             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6400             }
6401              
6402             # /b /B modifier
6403             elsif ($modifier =~ tr/bB//d) {
6404 8 0       47  
6405 0         0 # choice again delimiter
6406 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6407 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6408 0         0 my %octet = map {$_ => 1} @char;
6409 0         0 if (not $octet{')'}) {
6410             $delimiter = '(';
6411             $end_delimiter = ')';
6412 0         0 }
6413 0         0 elsif (not $octet{'}'}) {
6414             $delimiter = '{';
6415             $end_delimiter = '}';
6416 0         0 }
6417 0         0 elsif (not $octet{']'}) {
6418             $delimiter = '[';
6419             $end_delimiter = ']';
6420 0         0 }
6421 0         0 elsif (not $octet{'>'}) {
6422             $delimiter = '<';
6423             $end_delimiter = '>';
6424 0         0 }
6425 0 0       0 else {
6426 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6427 0         0 if (not $octet{$char}) {
6428 0         0 $delimiter = $char;
6429             $end_delimiter = $char;
6430             last;
6431             }
6432             }
6433             }
6434 0         0 }
6435 0         0  
6436             my $prematch = '';
6437             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6438 0 100       0 }
6439 68         206  
6440             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6441             my $metachar = qr/[\@\\|[\]{^]/oxms;
6442 68         273  
6443             # split regexp
6444             my @char = $string =~ /\G((?>
6445             [^\\\$\@\[\(] |
6446             \\ (?>[1-9][0-9]*) |
6447             \\g (?>\s*) (?>[1-9][0-9]*) |
6448             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6449             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6450             \\x (?>[0-9A-Fa-f]{1,2}) |
6451             \\ (?>[0-7]{2,3}) |
6452             \\c [\x40-\x5F] |
6453             \\x\{ (?>[0-9A-Fa-f]+) \} |
6454             \\o\{ (?>[0-7]+) \} |
6455             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6456             \\ $q_char |
6457             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6458             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6459             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6460             [\$\@] $qq_variable |
6461             \$ (?>\s* [0-9]+) |
6462             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6463             \$ \$ (?![\w\{]) |
6464             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6465             \[\^ |
6466             \[\: (?>[a-z]+) :\] |
6467             \[\:\^ (?>[a-z]+) :\] |
6468             \(\? |
6469             $q_char
6470             ))/oxmsg;
6471 68 50       15819  
6472 68         449 # choice again delimiter
  0         0  
6473 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6474 0         0 my %octet = map {$_ => 1} @char;
6475 0         0 if (not $octet{')'}) {
6476             $delimiter = '(';
6477             $end_delimiter = ')';
6478 0         0 }
6479 0         0 elsif (not $octet{'}'}) {
6480             $delimiter = '{';
6481             $end_delimiter = '}';
6482 0         0 }
6483 0         0 elsif (not $octet{']'}) {
6484             $delimiter = '[';
6485             $end_delimiter = ']';
6486 0         0 }
6487 0         0 elsif (not $octet{'>'}) {
6488             $delimiter = '<';
6489             $end_delimiter = '>';
6490 0         0 }
6491 0 0       0 else {
6492 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6493 0         0 if (not $octet{$char}) {
6494 0         0 $delimiter = $char;
6495             $end_delimiter = $char;
6496             last;
6497             }
6498             }
6499             }
6500             }
6501 0         0  
  68         138  
6502             # count '('
6503 253         429 my $parens = grep { $_ eq '(' } @char;
6504 68         104  
6505 68         120 my $left_e = 0;
6506             my $right_e = 0;
6507             for (my $i=0; $i <= $#char; $i++) {
6508 68 50 33     198  
    50 33        
    100          
    100          
    50          
    50          
6509 195         1271 # "\L\u" --> "\u\L"
6510             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6511             @char[$i,$i+1] = @char[$i+1,$i];
6512             }
6513              
6514 0         0 # "\U\l" --> "\l\U"
6515             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6516             @char[$i,$i+1] = @char[$i+1,$i];
6517             }
6518              
6519 0         0 # octal escape sequence
6520             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6521             $char[$i] = Elatin10::octchr($1);
6522             }
6523              
6524 1         3 # hexadecimal escape sequence
6525             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6526             $char[$i] = Elatin10::hexchr($1);
6527             }
6528              
6529             # \b{...} --> b\{...}
6530             # \B{...} --> B\{...}
6531             # \N{CHARNAME} --> N\{CHARNAME}
6532             # \p{PROPERTY} --> p\{PROPERTY}
6533 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6534             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6535             $char[$i] = $1 . '\\' . $2;
6536             }
6537              
6538 0         0 # \p, \P, \X --> p, P, X
6539             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6540             $char[$i] = $1;
6541 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          
6542              
6543             if (0) {
6544             }
6545 195         735  
6546 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6547 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6548             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)) {
6549             $char[$i] .= join '', splice @char, $i+1, 3;
6550 0         0 }
6551             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)) {
6552             $char[$i] .= join '', splice @char, $i+1, 2;
6553 0         0 }
6554             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)) {
6555             $char[$i] .= join '', splice @char, $i+1, 1;
6556             }
6557             }
6558              
6559 0         0 # open character class [...]
6560 13 50       31 elsif ($char[$i] eq '[') {
6561 13         51 my $left = $i;
6562             if ($char[$i+1] eq ']') {
6563 0         0 $i++;
6564 13 50       18 }
6565 58         113 while (1) {
6566             if (++$i > $#char) {
6567 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6568 58         118 }
6569             if ($char[$i] eq ']') {
6570             my $right = $i;
6571 13 50       21  
6572 13         77 # [...]
  0         0  
6573             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6574             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6575 0         0 }
6576             else {
6577             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6578 13         55 }
6579 13         23  
6580             $i = $left;
6581             last;
6582             }
6583             }
6584             }
6585              
6586 13         35 # open character class [^...]
6587 0 0       0 elsif ($char[$i] eq '[^') {
6588 0         0 my $left = $i;
6589             if ($char[$i+1] eq ']') {
6590 0         0 $i++;
6591 0 0       0 }
6592 0         0 while (1) {
6593             if (++$i > $#char) {
6594 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6595 0         0 }
6596             if ($char[$i] eq ']') {
6597             my $right = $i;
6598 0 0       0  
6599 0         0 # [^...]
  0         0  
6600             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6601             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6602 0         0 }
6603             else {
6604             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6605 0         0 }
6606 0         0  
6607             $i = $left;
6608             last;
6609             }
6610             }
6611             }
6612              
6613 0         0 # rewrite character class or escape character
6614             elsif (my $char = character_class($char[$i],$modifier)) {
6615             $char[$i] = $char;
6616             }
6617              
6618 7 50       14 # /i modifier
6619 3         7 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6620             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6621             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6622 3         7 }
6623             else {
6624             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6625             }
6626             }
6627              
6628 0 0       0 # \u \l \U \L \F \Q \E
6629 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6630             if ($right_e < $left_e) {
6631             $char[$i] = '\\' . $char[$i];
6632             }
6633 0         0 }
6634 0         0 elsif ($char[$i] eq '\u') {
6635             $char[$i] = '@{[Elatin10::ucfirst qq<';
6636             $left_e++;
6637 0         0 }
6638 0         0 elsif ($char[$i] eq '\l') {
6639             $char[$i] = '@{[Elatin10::lcfirst qq<';
6640             $left_e++;
6641 0         0 }
6642 0         0 elsif ($char[$i] eq '\U') {
6643             $char[$i] = '@{[Elatin10::uc qq<';
6644             $left_e++;
6645 0         0 }
6646 0         0 elsif ($char[$i] eq '\L') {
6647             $char[$i] = '@{[Elatin10::lc qq<';
6648             $left_e++;
6649 0         0 }
6650 0         0 elsif ($char[$i] eq '\F') {
6651             $char[$i] = '@{[Elatin10::fc qq<';
6652             $left_e++;
6653 0         0 }
6654 0         0 elsif ($char[$i] eq '\Q') {
6655             $char[$i] = '@{[CORE::quotemeta qq<';
6656             $left_e++;
6657 0 0       0 }
6658 0         0 elsif ($char[$i] eq '\E') {
6659 0         0 if ($right_e < $left_e) {
6660             $char[$i] = '>]}';
6661             $right_e++;
6662 0         0 }
6663             else {
6664             $char[$i] = '';
6665             }
6666 0         0 }
6667 0 0       0 elsif ($char[$i] eq '\Q') {
6668 0         0 while (1) {
6669             if (++$i > $#char) {
6670 0 0       0 last;
6671 0         0 }
6672             if ($char[$i] eq '\E') {
6673             last;
6674             }
6675             }
6676             }
6677             elsif ($char[$i] eq '\E') {
6678             }
6679              
6680             # \0 --> \0
6681             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6682             }
6683              
6684             # \g{N}, \g{-N}
6685              
6686             # P.108 Using Simple Patterns
6687             # in Chapter 7: In the World of Regular Expressions
6688             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6689              
6690             # P.221 Capturing
6691             # in Chapter 5: Pattern Matching
6692             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6693              
6694             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6695             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6696             }
6697              
6698             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6699             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6700             }
6701              
6702             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6703             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6704             }
6705              
6706             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6707             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6708             }
6709              
6710 0 0       0 # $0 --> $0
6711 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6712             if ($ignorecase) {
6713             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6714             }
6715 0 0       0 }
6716 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6717             if ($ignorecase) {
6718             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6719             }
6720             }
6721              
6722             # $$ --> $$
6723             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6724             }
6725              
6726             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6727 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6728 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6729 0         0 $char[$i] = e_capture($1);
6730             if ($ignorecase) {
6731             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6732             }
6733 0         0 }
6734 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6735 0         0 $char[$i] = e_capture($1);
6736             if ($ignorecase) {
6737             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6738             }
6739             }
6740              
6741 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6742 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) {
6743 0         0 $char[$i] = e_capture($1.'->'.$2);
6744             if ($ignorecase) {
6745             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6746             }
6747             }
6748              
6749 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6750 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) {
6751 0         0 $char[$i] = e_capture($1.'->'.$2);
6752             if ($ignorecase) {
6753             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6754             }
6755             }
6756              
6757 0         0 # $$foo
6758 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6759 0         0 $char[$i] = e_capture($1);
6760             if ($ignorecase) {
6761             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6762             }
6763             }
6764              
6765 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
6766 4         13 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6767             if ($ignorecase) {
6768             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
6769 0         0 }
6770             else {
6771             $char[$i] = '@{[Elatin10::PREMATCH()]}';
6772             }
6773             }
6774              
6775 4 50       14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
6776 4         16 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6777             if ($ignorecase) {
6778             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
6779 0         0 }
6780             else {
6781             $char[$i] = '@{[Elatin10::MATCH()]}';
6782             }
6783             }
6784              
6785 4 50       15 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
6786 3         25 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6787             if ($ignorecase) {
6788             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
6789 0         0 }
6790             else {
6791             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
6792             }
6793             }
6794              
6795 3 0       10 # ${ foo }
6796 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) {
6797             if ($ignorecase) {
6798             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6799             }
6800             }
6801              
6802 0         0 # ${ ... }
6803 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6804 0         0 $char[$i] = e_capture($1);
6805             if ($ignorecase) {
6806             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6807             }
6808             }
6809              
6810 0         0 # $scalar or @array
6811 4 50       28 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6812 4         22 $char[$i] = e_string($char[$i]);
6813             if ($ignorecase) {
6814             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6815             }
6816             }
6817              
6818 0 50       0 # quote character before ? + * {
6819             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6820             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6821 13         66 }
6822             else {
6823             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6824             }
6825             }
6826             }
6827 13         66  
6828 68         159 # make regexp string
6829 68 50       118 my $prematch = '';
6830 68         182 $modifier =~ tr/i//d;
6831             if ($left_e > $right_e) {
6832 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6833             }
6834             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6835             }
6836              
6837             #
6838             # escape regexp (s'here'' or s'here''b)
6839 68     21 0 782 #
6840 21   100     46 sub e_s1_q {
6841             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6842 21         67 $modifier ||= '';
6843 21 50       25  
6844 21         41 $modifier =~ tr/p//d;
6845 0         0 if ($modifier =~ /([adlu])/oxms) {
6846 0 0       0 my $line = 0;
6847 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6848 0         0 if ($filename ne __FILE__) {
6849             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6850             last;
6851 0         0 }
6852             }
6853             die qq{Unsupported modifier "$1" used at line $line.\n};
6854 0         0 }
6855              
6856             $slash = 'div';
6857 21 100       29  
    50          
6858 21         56 # literal null string pattern
6859 8         10 if ($string eq '') {
6860 8         9 $modifier =~ tr/bB//d;
6861             $modifier =~ tr/i//d;
6862             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6863             }
6864              
6865 8         43 # with /b /B modifier
6866             elsif ($modifier =~ tr/bB//d) {
6867             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6868             }
6869              
6870 0         0 # without /b /B modifier
6871             else {
6872             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6873             }
6874             }
6875              
6876             #
6877             # escape regexp (s'here'')
6878 13     13 0 30 #
6879             sub e_s1_qt {
6880 13 50       31 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6881              
6882             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6883 13         25  
6884             # split regexp
6885             my @char = $string =~ /\G((?>
6886             [^\\\[\$\@\/] |
6887             [\x00-\xFF] |
6888             \[\^ |
6889             \[\: (?>[a-z]+) \:\] |
6890             \[\:\^ (?>[a-z]+) \:\] |
6891             [\$\@\/] |
6892             \\ (?:$q_char) |
6893             (?:$q_char)
6894             ))/oxmsg;
6895 13         202  
6896 13 50 33     41 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6897             for (my $i=0; $i <= $#char; $i++) {
6898             if (0) {
6899             }
6900 25         97  
6901 0         0 # open character class [...]
6902 0 0       0 elsif ($char[$i] eq '[') {
6903 0         0 my $left = $i;
6904             if ($char[$i+1] eq ']') {
6905 0         0 $i++;
6906 0 0       0 }
6907 0         0 while (1) {
6908             if (++$i > $#char) {
6909 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6910 0         0 }
6911             if ($char[$i] eq ']') {
6912             my $right = $i;
6913 0         0  
6914             # [...]
6915 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6916 0         0  
6917             $i = $left;
6918             last;
6919             }
6920             }
6921             }
6922              
6923 0         0 # open character class [^...]
6924 0 0       0 elsif ($char[$i] eq '[^') {
6925 0         0 my $left = $i;
6926             if ($char[$i+1] eq ']') {
6927 0         0 $i++;
6928 0 0       0 }
6929 0         0 while (1) {
6930             if (++$i > $#char) {
6931 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6932 0         0 }
6933             if ($char[$i] eq ']') {
6934             my $right = $i;
6935 0         0  
6936             # [^...]
6937 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6938 0         0  
6939             $i = $left;
6940             last;
6941             }
6942             }
6943             }
6944              
6945 0         0 # escape $ @ / and \
6946             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6947             $char[$i] = '\\' . $char[$i];
6948             }
6949              
6950 0         0 # rewrite character class or escape character
6951             elsif (my $char = character_class($char[$i],$modifier)) {
6952             $char[$i] = $char;
6953             }
6954              
6955 6 0       12 # /i modifier
6956 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6957             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6958             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6959 0         0 }
6960             else {
6961             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6962             }
6963             }
6964              
6965 0 0       0 # quote character before ? + * {
6966             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6967             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6968 0         0 }
6969             else {
6970             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6971             }
6972             }
6973 0         0 }
6974 13         21  
6975 13         22 $modifier =~ tr/i//d;
6976 13         17 $delimiter = '/';
6977 13         18 $end_delimiter = '/';
6978             my $prematch = '';
6979             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6980             }
6981              
6982             #
6983             # escape regexp (s'here''b)
6984 13     0 0 92 #
6985             sub e_s1_qb {
6986             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6987 0         0  
6988             # split regexp
6989             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6990 0         0  
6991 0 0       0 # unescape character
    0          
6992             for (my $i=0; $i <= $#char; $i++) {
6993             if (0) {
6994             }
6995 0         0  
6996             # remain \\
6997             elsif ($char[$i] eq '\\\\') {
6998             }
6999              
7000 0         0 # escape $ @ / and \
7001             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7002             $char[$i] = '\\' . $char[$i];
7003             }
7004 0         0 }
7005 0         0  
7006 0         0 $delimiter = '/';
7007 0         0 $end_delimiter = '/';
7008             my $prematch = '';
7009             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7010             }
7011              
7012             #
7013             # escape regexp (s''here')
7014 0     16 0 0 #
7015             sub e_s2_q {
7016 16         35 my($ope,$delimiter,$end_delimiter,$string) = @_;
7017              
7018 16         18 $slash = 'div';
7019 16         90  
7020 16 100       68 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7021             for (my $i=0; $i <= $#char; $i++) {
7022             if (0) {
7023             }
7024 9         27  
7025             # not escape \\
7026             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7027             }
7028              
7029 0         0 # escape $ @ / and \
7030             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7031             $char[$i] = '\\' . $char[$i];
7032             }
7033 5         17 }
7034              
7035             return join '', $ope, $delimiter, @char, $end_delimiter;
7036             }
7037              
7038             #
7039             # escape regexp (s/here/and here/modifier)
7040 16     97 0 53 #
7041 97   100     769 sub e_sub {
7042             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7043 97         408 $modifier ||= '';
7044 97 50       176  
7045 97         270 $modifier =~ tr/p//d;
7046 0         0 if ($modifier =~ /([adlu])/oxms) {
7047 0 0       0 my $line = 0;
7048 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7049 0         0 if ($filename ne __FILE__) {
7050             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7051             last;
7052 0         0 }
7053             }
7054             die qq{Unsupported modifier "$1" used at line $line.\n};
7055 0 100       0 }
7056 97         253  
7057 36         47 if ($variable eq '') {
7058             $variable = '$_';
7059             $bind_operator = ' =~ ';
7060 36         48 }
7061              
7062             $slash = 'div';
7063              
7064             # P.128 Start of match (or end of previous match): \G
7065             # P.130 Advanced Use of \G with Perl
7066             # in Chapter 3: Overview of Regular Expression Features and Flavors
7067             # P.312 Iterative Matching: Scalar Context, with /g
7068             # in Chapter 7: Perl
7069             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7070              
7071             # P.181 Where You Left Off: The \G Assertion
7072             # in Chapter 5: Pattern Matching
7073             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7074              
7075             # P.220 Where You Left Off: The \G Assertion
7076             # in Chapter 5: Pattern Matching
7077 97         148 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7078 97         160  
7079             my $e_modifier = $modifier =~ tr/e//d;
7080 97         151 my $r_modifier = $modifier =~ tr/r//d;
7081 97 50       139  
7082 97         261 my $my = '';
7083 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7084 0         0 $my = $variable;
7085             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7086             $variable =~ s/ = .+ \z//oxms;
7087 0         0 }
7088 97         242  
7089             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7090             $variable_basename =~ s/ \s+ \z//oxms;
7091 97         172  
7092 97 100       151 # quote replacement string
7093 97         204 my $e_replacement = '';
7094 17         33 if ($e_modifier >= 1) {
7095             $e_replacement = e_qq('', '', '', $replacement);
7096             $e_modifier--;
7097 17 100       25 }
7098 80         172 else {
7099             if ($delimiter2 eq "'") {
7100             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7101 16         29 }
7102             else {
7103             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7104             }
7105 64         165 }
7106              
7107             my $sub = '';
7108 97 100       180  
7109 97 100       284 # with /r
7110             if ($r_modifier) {
7111             if (0) {
7112             }
7113 8         25  
7114 0 50       0 # s///gr without multibyte anchoring
7115             elsif ($modifier =~ /g/oxms) {
7116             $sub = sprintf(
7117             # 1 2 3 4 5
7118             q,
7119              
7120             $variable, # 1
7121             ($delimiter1 eq "'") ? # 2
7122             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7123             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7124             $s_matched, # 3
7125             $e_replacement, # 4
7126             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
7127             );
7128             }
7129              
7130             # s///r
7131 4         21 else {
7132              
7133 4 50       9 my $prematch = q{$`};
7134              
7135             $sub = sprintf(
7136             # 1 2 3 4 5 6 7
7137             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s"%s$Elatin10::re_r$'" } : %s>,
7138              
7139             $variable, # 1
7140             ($delimiter1 eq "'") ? # 2
7141             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7142             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7143             $s_matched, # 3
7144             $e_replacement, # 4
7145             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
7146             $prematch, # 6
7147             $variable, # 7
7148             );
7149             }
7150 4 50       54  
7151 8         29 # $var !~ s///r doesn't make sense
7152             if ($bind_operator =~ / !~ /oxms) {
7153             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7154             }
7155             }
7156              
7157 0 100       0 # without /r
7158             else {
7159             if (0) {
7160             }
7161 89         219  
7162 0 100       0 # s///g without multibyte anchoring
    100          
7163             elsif ($modifier =~ /g/oxms) {
7164             $sub = sprintf(
7165             # 1 2 3 4 5 6 7 8
7166             q,
7167              
7168             $variable, # 1
7169             ($delimiter1 eq "'") ? # 2
7170             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7171             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7172             $s_matched, # 3
7173             $e_replacement, # 4
7174             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
7175             $variable, # 6
7176             $variable, # 7
7177             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7178             );
7179             }
7180              
7181             # s///
7182 22         79 else {
7183              
7184 67 100       109 my $prematch = q{$`};
    100          
7185              
7186             $sub = sprintf(
7187              
7188             ($bind_operator =~ / =~ /oxms) ?
7189              
7190             # 1 2 3 4 5 6 7 8
7191             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s%s="%s$Elatin10::re_r$'"; 1 } : undef> :
7192              
7193             # 1 2 3 4 5 6 7 8
7194             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s%s="%s$Elatin10::re_r$'"; undef }>,
7195              
7196             $variable, # 1
7197             $bind_operator, # 2
7198             ($delimiter1 eq "'") ? # 3
7199             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7200             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7201             $s_matched, # 4
7202             $e_replacement, # 5
7203             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 6
7204             $variable, # 7
7205             $prematch, # 8
7206             );
7207             }
7208             }
7209 67 50       363  
7210 97         271 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7211             if ($my ne '') {
7212             $sub = "($my, $sub)[1]";
7213             }
7214 0         0  
7215 97         153 # clear s/// variable
7216             $sub_variable = '';
7217 97         133 $bind_operator = '';
7218              
7219             return $sub;
7220             }
7221              
7222             #
7223             # escape regexp of split qr//
7224 97     74 0 660 #
7225 74   100     400 sub e_split {
7226             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7227 74         365 $modifier ||= '';
7228 74 50       131  
7229 74         210 $modifier =~ tr/p//d;
7230 0         0 if ($modifier =~ /([adlu])/oxms) {
7231 0 0       0 my $line = 0;
7232 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7233 0         0 if ($filename ne __FILE__) {
7234             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7235             last;
7236 0         0 }
7237             }
7238             die qq{Unsupported modifier "$1" used at line $line.\n};
7239 0         0 }
7240              
7241             $slash = 'div';
7242 74 50       118  
7243 74         182 # /b /B modifier
7244             if ($modifier =~ tr/bB//d) {
7245             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7246 0 50       0 }
7247 74         225  
7248             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7249             my $metachar = qr/[\@\\|[\]{^]/oxms;
7250 74         323  
7251             # split regexp
7252             my @char = $string =~ /\G((?>
7253             [^\\\$\@\[\(] |
7254             \\x (?>[0-9A-Fa-f]{1,2}) |
7255             \\ (?>[0-7]{2,3}) |
7256             \\c [\x40-\x5F] |
7257             \\x\{ (?>[0-9A-Fa-f]+) \} |
7258             \\o\{ (?>[0-7]+) \} |
7259             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7260             \\ $q_char |
7261             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7262             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7263             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7264             [\$\@] $qq_variable |
7265             \$ (?>\s* [0-9]+) |
7266             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7267             \$ \$ (?![\w\{]) |
7268             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7269             \[\^ |
7270             \[\: (?>[a-z]+) :\] |
7271             \[\:\^ (?>[a-z]+) :\] |
7272             \(\? |
7273             $q_char
7274 74         8905 ))/oxmsg;
7275 74         241  
7276 74         105 my $left_e = 0;
7277             my $right_e = 0;
7278             for (my $i=0; $i <= $#char; $i++) {
7279 74 50 33     346  
    50 33        
    100          
    100          
    50          
    50          
7280 249         1477 # "\L\u" --> "\u\L"
7281             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7282             @char[$i,$i+1] = @char[$i+1,$i];
7283             }
7284              
7285 0         0 # "\U\l" --> "\l\U"
7286             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7287             @char[$i,$i+1] = @char[$i+1,$i];
7288             }
7289              
7290 0         0 # octal escape sequence
7291             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7292             $char[$i] = Elatin10::octchr($1);
7293             }
7294              
7295 1         3 # hexadecimal escape sequence
7296             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7297             $char[$i] = Elatin10::hexchr($1);
7298             }
7299              
7300             # \b{...} --> b\{...}
7301             # \B{...} --> B\{...}
7302             # \N{CHARNAME} --> N\{CHARNAME}
7303             # \p{PROPERTY} --> p\{PROPERTY}
7304 1         3 # \P{PROPERTY} --> P\{PROPERTY}
7305             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7306             $char[$i] = $1 . '\\' . $2;
7307             }
7308              
7309 0         0 # \p, \P, \X --> p, P, X
7310             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7311             $char[$i] = $1;
7312 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          
7313              
7314             if (0) {
7315             }
7316 249         817  
7317 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7318 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7319             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)) {
7320             $char[$i] .= join '', splice @char, $i+1, 3;
7321 0         0 }
7322             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)) {
7323             $char[$i] .= join '', splice @char, $i+1, 2;
7324 0         0 }
7325             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)) {
7326             $char[$i] .= join '', splice @char, $i+1, 1;
7327             }
7328             }
7329              
7330 0         0 # open character class [...]
7331 3 50       5 elsif ($char[$i] eq '[') {
7332 3         10 my $left = $i;
7333             if ($char[$i+1] eq ']') {
7334 0         0 $i++;
7335 3 50       3 }
7336 7         12 while (1) {
7337             if (++$i > $#char) {
7338 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7339 7         15 }
7340             if ($char[$i] eq ']') {
7341             my $right = $i;
7342 3 50       3  
7343 3         19 # [...]
  0         0  
7344             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7345             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7346 0         0 }
7347             else {
7348             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7349 3         15 }
7350 3         6  
7351             $i = $left;
7352             last;
7353             }
7354             }
7355             }
7356              
7357 3         8 # open character class [^...]
7358 0 0       0 elsif ($char[$i] eq '[^') {
7359 0         0 my $left = $i;
7360             if ($char[$i+1] eq ']') {
7361 0         0 $i++;
7362 0 0       0 }
7363 0         0 while (1) {
7364             if (++$i > $#char) {
7365 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7366 0         0 }
7367             if ($char[$i] eq ']') {
7368             my $right = $i;
7369 0 0       0  
7370 0         0 # [^...]
  0         0  
7371             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7372             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7373 0         0 }
7374             else {
7375             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7376 0         0 }
7377 0         0  
7378             $i = $left;
7379             last;
7380             }
7381             }
7382             }
7383              
7384 0         0 # rewrite character class or escape character
7385             elsif (my $char = character_class($char[$i],$modifier)) {
7386             $char[$i] = $char;
7387             }
7388              
7389             # P.794 29.2.161. split
7390             # in Chapter 29: Functions
7391             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7392              
7393             # P.951 split
7394             # in Chapter 27: Functions
7395             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7396              
7397             # said "The //m modifier is assumed when you split on the pattern /^/",
7398             # but perl5.008 is not so. Therefore, this software adds //m.
7399             # (and so on)
7400              
7401 1         3 # split(m/^/) --> split(m/^/m)
7402             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7403             $modifier .= 'm';
7404             }
7405              
7406 7 0       21 # /i modifier
7407 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7408             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7409             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7410 0         0 }
7411             else {
7412             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7413             }
7414             }
7415              
7416 0 0       0 # \u \l \U \L \F \Q \E
7417 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7418             if ($right_e < $left_e) {
7419             $char[$i] = '\\' . $char[$i];
7420             }
7421 0         0 }
7422 0         0 elsif ($char[$i] eq '\u') {
7423             $char[$i] = '@{[Elatin10::ucfirst qq<';
7424             $left_e++;
7425 0         0 }
7426 0         0 elsif ($char[$i] eq '\l') {
7427             $char[$i] = '@{[Elatin10::lcfirst qq<';
7428             $left_e++;
7429 0         0 }
7430 0         0 elsif ($char[$i] eq '\U') {
7431             $char[$i] = '@{[Elatin10::uc qq<';
7432             $left_e++;
7433 0         0 }
7434 0         0 elsif ($char[$i] eq '\L') {
7435             $char[$i] = '@{[Elatin10::lc qq<';
7436             $left_e++;
7437 0         0 }
7438 0         0 elsif ($char[$i] eq '\F') {
7439             $char[$i] = '@{[Elatin10::fc qq<';
7440             $left_e++;
7441 0         0 }
7442 0         0 elsif ($char[$i] eq '\Q') {
7443             $char[$i] = '@{[CORE::quotemeta qq<';
7444             $left_e++;
7445 0 0       0 }
7446 0         0 elsif ($char[$i] eq '\E') {
7447 0         0 if ($right_e < $left_e) {
7448             $char[$i] = '>]}';
7449             $right_e++;
7450 0         0 }
7451             else {
7452             $char[$i] = '';
7453             }
7454 0         0 }
7455 0 0       0 elsif ($char[$i] eq '\Q') {
7456 0         0 while (1) {
7457             if (++$i > $#char) {
7458 0 0       0 last;
7459 0         0 }
7460             if ($char[$i] eq '\E') {
7461             last;
7462             }
7463             }
7464             }
7465             elsif ($char[$i] eq '\E') {
7466             }
7467              
7468 0 0       0 # $0 --> $0
7469 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7470             if ($ignorecase) {
7471             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7472             }
7473 0 0       0 }
7474 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7475             if ($ignorecase) {
7476             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7477             }
7478             }
7479              
7480             # $$ --> $$
7481             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7482             }
7483              
7484             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7485 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7486 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7487 0         0 $char[$i] = e_capture($1);
7488             if ($ignorecase) {
7489             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7490             }
7491 0         0 }
7492 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7493 0         0 $char[$i] = e_capture($1);
7494             if ($ignorecase) {
7495             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7496             }
7497             }
7498              
7499 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7500 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) {
7501 0         0 $char[$i] = e_capture($1.'->'.$2);
7502             if ($ignorecase) {
7503             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7504             }
7505             }
7506              
7507 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7508 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) {
7509 0         0 $char[$i] = e_capture($1.'->'.$2);
7510             if ($ignorecase) {
7511             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7512             }
7513             }
7514              
7515 0         0 # $$foo
7516 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7517 0         0 $char[$i] = e_capture($1);
7518             if ($ignorecase) {
7519             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7520             }
7521             }
7522              
7523 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
7524 12         31 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7525             if ($ignorecase) {
7526             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
7527 0         0 }
7528             else {
7529             $char[$i] = '@{[Elatin10::PREMATCH()]}';
7530             }
7531             }
7532              
7533 12 50       53 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
7534 12         42 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7535             if ($ignorecase) {
7536             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
7537 0         0 }
7538             else {
7539             $char[$i] = '@{[Elatin10::MATCH()]}';
7540             }
7541             }
7542              
7543 12 50       51 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
7544 9         21 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7545             if ($ignorecase) {
7546             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
7547 0         0 }
7548             else {
7549             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
7550             }
7551             }
7552              
7553 9 0       41 # ${ foo }
7554 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) {
7555             if ($ignorecase) {
7556             $char[$i] = '@{[Elatin10::ignorecase(' . $1 . ')]}';
7557             }
7558             }
7559              
7560 0         0 # ${ ... }
7561 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7562 0         0 $char[$i] = e_capture($1);
7563             if ($ignorecase) {
7564             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7565             }
7566             }
7567              
7568 0         0 # $scalar or @array
7569 3 50       10 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7570 3         13 $char[$i] = e_string($char[$i]);
7571             if ($ignorecase) {
7572             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7573             }
7574             }
7575              
7576 0 50       0 # quote character before ? + * {
7577             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7578             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7579 1         7 }
7580             else {
7581             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7582             }
7583             }
7584             }
7585 0         0  
7586 74 50       232 # make regexp string
7587 74         149 $modifier =~ tr/i//d;
7588             if ($left_e > $right_e) {
7589 0         0 return join '', 'Elatin10::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7590             }
7591             return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7592             }
7593              
7594             #
7595             # escape regexp of split qr''
7596 74     0 0 694 #
7597 0   0       sub e_split_q {
7598             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7599 0           $modifier ||= '';
7600 0 0          
7601 0           $modifier =~ tr/p//d;
7602 0           if ($modifier =~ /([adlu])/oxms) {
7603 0 0         my $line = 0;
7604 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7605 0           if ($filename ne __FILE__) {
7606             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7607             last;
7608 0           }
7609             }
7610             die qq{Unsupported modifier "$1" used at line $line.\n};
7611 0           }
7612              
7613             $slash = 'div';
7614 0 0          
7615 0           # /b /B modifier
7616             if ($modifier =~ tr/bB//d) {
7617             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7618 0 0         }
7619              
7620             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7621 0            
7622             # split regexp
7623             my @char = $string =~ /\G((?>
7624             [^\\\[] |
7625             [\x00-\xFF] |
7626             \[\^ |
7627             \[\: (?>[a-z]+) \:\] |
7628             \[\:\^ (?>[a-z]+) \:\] |
7629             \\ (?:$q_char) |
7630             (?:$q_char)
7631             ))/oxmsg;
7632 0            
7633 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7634             for (my $i=0; $i <= $#char; $i++) {
7635             if (0) {
7636             }
7637 0            
7638 0           # open character class [...]
7639 0 0         elsif ($char[$i] eq '[') {
7640 0           my $left = $i;
7641             if ($char[$i+1] eq ']') {
7642 0           $i++;
7643 0 0         }
7644 0           while (1) {
7645             if (++$i > $#char) {
7646 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7647 0           }
7648             if ($char[$i] eq ']') {
7649             my $right = $i;
7650 0            
7651             # [...]
7652 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7653 0            
7654             $i = $left;
7655             last;
7656             }
7657             }
7658             }
7659              
7660 0           # open character class [^...]
7661 0 0         elsif ($char[$i] eq '[^') {
7662 0           my $left = $i;
7663             if ($char[$i+1] eq ']') {
7664 0           $i++;
7665 0 0         }
7666 0           while (1) {
7667             if (++$i > $#char) {
7668 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7669 0           }
7670             if ($char[$i] eq ']') {
7671             my $right = $i;
7672 0            
7673             # [^...]
7674 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7675 0            
7676             $i = $left;
7677             last;
7678             }
7679             }
7680             }
7681              
7682 0           # rewrite character class or escape character
7683             elsif (my $char = character_class($char[$i],$modifier)) {
7684             $char[$i] = $char;
7685             }
7686              
7687 0           # split(m/^/) --> split(m/^/m)
7688             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7689             $modifier .= 'm';
7690             }
7691              
7692 0 0         # /i modifier
7693 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7694             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7695             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7696 0           }
7697             else {
7698             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7699             }
7700             }
7701              
7702 0 0         # quote character before ? + * {
7703             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7704             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7705 0           }
7706             else {
7707             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7708             }
7709             }
7710 0           }
7711 0            
7712             $modifier =~ tr/i//d;
7713             return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7714             }
7715              
7716             #
7717             # instead of Carp::carp
7718 0     0 0   #
7719 0           sub carp {
7720             my($package,$filename,$line) = caller(1);
7721             print STDERR "@_ at $filename line $line.\n";
7722             }
7723              
7724             #
7725             # instead of Carp::croak
7726 0     0 0   #
7727 0           sub croak {
7728 0           my($package,$filename,$line) = caller(1);
7729             print STDERR "@_ at $filename line $line.\n";
7730             die "\n";
7731             }
7732              
7733             #
7734             # instead of Carp::cluck
7735 0     0 0   #
7736 0           sub cluck {
7737 0           my $i = 0;
7738 0           my @cluck = ();
7739 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7740             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7741 0           $i++;
7742 0           }
7743 0           print STDERR CORE::reverse @cluck;
7744             print STDERR "\n";
7745             print STDERR @_;
7746             }
7747              
7748             #
7749             # instead of Carp::confess
7750 0     0 0   #
7751 0           sub confess {
7752 0           my $i = 0;
7753 0           my @confess = ();
7754 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7755             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7756 0           $i++;
7757 0           }
7758 0           print STDERR CORE::reverse @confess;
7759 0           print STDERR "\n";
7760             print STDERR @_;
7761             die "\n";
7762             }
7763              
7764             1;
7765              
7766             __END__