File Coverage

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


line stmt bran cond sub pod time code
1             package Elatin10;
2 204     204   2898 use strict;
  204         336  
  204         8056  
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   3396 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         645  
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   1034 use vars qw($VERSION);
  204         365  
  204         35660  
28             $VERSION = '1.15';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1468 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         430 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         28976 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   33557 CORE::eval q{
  204     204   1225  
  204     66   686  
  204         23585  
  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       82590 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     0 0 0 my($name) = @_;
78              
79 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
80 0         0 return $name;
81             }
82             elsif (Elatin10::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Elatin10::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 0         0 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 0   0 0 0 if (defined $_[1]) {
117 204     204   1601 no strict qw(refs);
  204         1458  
  204         16013  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   2285 no strict qw(refs);
  204     0   398  
  204         38100  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x00-\xFF]};
153 204     204   1373 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         349  
  204         13291  
154 204     204   1373 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         399  
  204         436659  
155              
156             #
157             # Latin-10 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Latin-10 case conversion
163             #
164             my %lc = ();
165             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
166             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
167             my %uc = ();
168             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
169             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
170             my %fc = ();
171             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
172             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Elatin10 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xA1" => "\xA2", # LATIN LETTER A WITH OGONEK
185             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
186             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
187             "\xAA" => "\xBA", # LATIN LETTER S WITH COMMA BELOW
188             "\xAC" => "\xAE", # LATIN LETTER Z WITH ACUTE
189             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
190             "\xB2" => "\xB9", # LATIN LETTER C WITH CARON
191             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
192             "\xBC" => "\xBD", # LATIN LIGATURE OE
193             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
194             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
195             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
196             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
197             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
198             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
199             "\xC5" => "\xE5", # LATIN LETTER C WITH ACUTE
200             "\xC6" => "\xE6", # LATIN LETTER AE
201             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
202             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
203             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
204             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
205             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
206             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
207             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
208             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
209             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
210             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
211             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
212             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
213             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
214             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
215             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
216             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
217             "\xD7" => "\xF7", # LATIN LETTER S WITH ACUTE
218             "\xD8" => "\xF8", # LATIN LETTER U WITH DOUBLE ACUTE
219             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
220             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
221             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
222             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
223             "\xDD" => "\xFD", # LATIN LETTER E WITH OGONEK
224             "\xDE" => "\xFE", # LATIN LETTER T WITH COMMA BELOW
225             );
226              
227             %uc = (%uc,
228             "\xA2" => "\xA1", # LATIN LETTER A WITH OGONEK
229             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
230             "\xAE" => "\xAC", # LATIN LETTER Z WITH ACUTE
231             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
232             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
233             "\xB9" => "\xB2", # LATIN LETTER C WITH CARON
234             "\xBA" => "\xAA", # LATIN LETTER S WITH COMMA BELOW
235             "\xBD" => "\xBC", # LATIN LIGATURE OE
236             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
237             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
238             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
239             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
240             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
241             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
242             "\xE5" => "\xC5", # LATIN LETTER C WITH ACUTE
243             "\xE6" => "\xC6", # LATIN LETTER AE
244             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
245             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
246             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
247             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
248             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
249             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
250             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
251             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
252             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
253             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
254             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
255             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
256             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
257             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
258             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
259             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
260             "\xF7" => "\xD7", # LATIN LETTER S WITH ACUTE
261             "\xF8" => "\xD8", # LATIN LETTER U WITH DOUBLE ACUTE
262             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
263             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
264             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
265             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
266             "\xFD" => "\xDD", # LATIN LETTER E WITH OGONEK
267             "\xFE" => "\xDE", # LATIN LETTER T WITH COMMA BELOW
268             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
269             );
270              
271             %fc = (%fc,
272             "\xA1" => "\xA2", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
273             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
274             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
275             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH COMMA BELOW --> LATIN SMALL LETTER S WITH COMMA BELOW
276             "\xAC" => "\xAE", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
277             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
278             "\xB2" => "\xB9", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
279             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
280             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
281             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
282             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
283             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
284             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
285             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
286             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
287             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
288             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
289             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
290             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
291             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
292             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
293             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
294             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
295             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
296             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
297             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
298             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
299             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
300             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
301             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
302             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
303             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
304             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
305             "\xD7" => "\xF7", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
306             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
307             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
308             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
309             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
310             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
311             "\xDD" => "\xFD", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
312             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH COMMA BELOW --> LATIN SMALL LETTER T WITH COMMA BELOW
313             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
314             );
315             }
316              
317             else {
318             croak "Don't know my package name '@{[__PACKAGE__]}'";
319             }
320              
321             #
322             # @ARGV wildcard globbing
323             #
324             sub import {
325              
326 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
327 0         0 my @argv = ();
328 0         0 for (@ARGV) {
329              
330             # has space
331 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
332 0 0       0 if (my @glob = Elatin10::glob(qq{"$_"})) {
333 0         0 push @argv, @glob;
334             }
335             else {
336 0         0 push @argv, $_;
337             }
338             }
339              
340             # has wildcard metachar
341             elsif (/\A (?:$q_char)*? [*?] /oxms) {
342 0 0       0 if (my @glob = Elatin10::glob($_)) {
343 0         0 push @argv, @glob;
344             }
345             else {
346 0         0 push @argv, $_;
347             }
348             }
349              
350             # no wildcard globbing
351             else {
352 0         0 push @argv, $_;
353             }
354             }
355 0         0 @ARGV = @argv;
356             }
357              
358 0         0 *Char::ord = \&Latin10::ord;
359 0         0 *Char::ord_ = \&Latin10::ord_;
360 0         0 *Char::reverse = \&Latin10::reverse;
361 0         0 *Char::getc = \&Latin10::getc;
362 0         0 *Char::length = \&Latin10::length;
363 0         0 *Char::substr = \&Latin10::substr;
364 0         0 *Char::index = \&Latin10::index;
365 0         0 *Char::rindex = \&Latin10::rindex;
366 0         0 *Char::eval = \&Latin10::eval;
367 0         0 *Char::escape = \&Latin10::escape;
368 0         0 *Char::escape_token = \&Latin10::escape_token;
369 0         0 *Char::escape_script = \&Latin10::escape_script;
370             }
371              
372             # P.230 Care with Prototypes
373             # in Chapter 6: Subroutines
374             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
375             #
376             # If you aren't careful, you can get yourself into trouble with prototypes.
377             # But if you are careful, you can do a lot of neat things with them. This is
378             # all very powerful, of course, and should only be used in moderation to make
379             # the world a better place.
380              
381             # P.332 Care with Prototypes
382             # in Chapter 7: Subroutines
383             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
384             #
385             # If you aren't careful, you can get yourself into trouble with prototypes.
386             # But if you are careful, you can do a lot of neat things with them. This is
387             # all very powerful, of course, and should only be used in moderation to make
388             # the world a better place.
389              
390             #
391             # Prototypes of subroutines
392             #
393       0     sub unimport {}
394             sub Elatin10::split(;$$$);
395             sub Elatin10::tr($$$$;$);
396             sub Elatin10::chop(@);
397             sub Elatin10::index($$;$);
398             sub Elatin10::rindex($$;$);
399             sub Elatin10::lcfirst(@);
400             sub Elatin10::lcfirst_();
401             sub Elatin10::lc(@);
402             sub Elatin10::lc_();
403             sub Elatin10::ucfirst(@);
404             sub Elatin10::ucfirst_();
405             sub Elatin10::uc(@);
406             sub Elatin10::uc_();
407             sub Elatin10::fc(@);
408             sub Elatin10::fc_();
409             sub Elatin10::ignorecase;
410             sub Elatin10::classic_character_class;
411             sub Elatin10::capture;
412             sub Elatin10::chr(;$);
413             sub Elatin10::chr_();
414             sub Elatin10::glob($);
415             sub Elatin10::glob_();
416              
417             sub Latin10::ord(;$);
418             sub Latin10::ord_();
419             sub Latin10::reverse(@);
420             sub Latin10::getc(;*@);
421             sub Latin10::length(;$);
422             sub Latin10::substr($$;$$);
423             sub Latin10::index($$;$);
424             sub Latin10::rindex($$;$);
425             sub Latin10::escape(;$);
426              
427             #
428             # Regexp work
429             #
430 204         18278 use vars qw(
431             $re_a
432             $re_t
433             $re_n
434             $re_r
435 204     204   1833 );
  204         371  
436              
437             #
438             # Character class
439             #
440 204         2240311 use vars qw(
441             $dot
442             $dot_s
443             $eD
444             $eS
445             $eW
446             $eH
447             $eV
448             $eR
449             $eN
450             $not_alnum
451             $not_alpha
452             $not_ascii
453             $not_blank
454             $not_cntrl
455             $not_digit
456             $not_graph
457             $not_lower
458             $not_lower_i
459             $not_print
460             $not_punct
461             $not_space
462             $not_upper
463             $not_upper_i
464             $not_word
465             $not_xdigit
466             $eb
467             $eB
468 204     204   1363 );
  204         369  
469              
470             ${Elatin10::dot} = qr{(?>[^\x0A])};
471             ${Elatin10::dot_s} = qr{(?>[\x00-\xFF])};
472             ${Elatin10::eD} = qr{(?>[^0-9])};
473              
474             # Vertical tabs are now whitespace
475             # \s in a regex now matches a vertical tab in all circumstances.
476             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
477             # ${Elatin10::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
478             # ${Elatin10::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
479             ${Elatin10::eS} = qr{(?>[^\s])};
480              
481             ${Elatin10::eW} = qr{(?>[^0-9A-Z_a-z])};
482             ${Elatin10::eH} = qr{(?>[^\x09\x20])};
483             ${Elatin10::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
484             ${Elatin10::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
485             ${Elatin10::eN} = qr{(?>[^\x0A])};
486             ${Elatin10::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
487             ${Elatin10::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
488             ${Elatin10::not_ascii} = qr{(?>[^\x00-\x7F])};
489             ${Elatin10::not_blank} = qr{(?>[^\x09\x20])};
490             ${Elatin10::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
491             ${Elatin10::not_digit} = qr{(?>[^\x30-\x39])};
492             ${Elatin10::not_graph} = qr{(?>[^\x21-\x7F])};
493             ${Elatin10::not_lower} = qr{(?>[^\x61-\x7A])};
494             ${Elatin10::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
495             # ${Elatin10::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
496             ${Elatin10::not_print} = qr{(?>[^\x20-\x7F])};
497             ${Elatin10::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
498             ${Elatin10::not_space} = qr{(?>[^\s\x0B])};
499             ${Elatin10::not_upper} = qr{(?>[^\x41-\x5A])};
500             ${Elatin10::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
501             # ${Elatin10::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
502             ${Elatin10::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
503             ${Elatin10::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
504             ${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))};
505             ${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]))};
506              
507             # avoid: Name "Elatin10::foo" used only once: possible typo at here.
508             ${Elatin10::dot} = ${Elatin10::dot};
509             ${Elatin10::dot_s} = ${Elatin10::dot_s};
510             ${Elatin10::eD} = ${Elatin10::eD};
511             ${Elatin10::eS} = ${Elatin10::eS};
512             ${Elatin10::eW} = ${Elatin10::eW};
513             ${Elatin10::eH} = ${Elatin10::eH};
514             ${Elatin10::eV} = ${Elatin10::eV};
515             ${Elatin10::eR} = ${Elatin10::eR};
516             ${Elatin10::eN} = ${Elatin10::eN};
517             ${Elatin10::not_alnum} = ${Elatin10::not_alnum};
518             ${Elatin10::not_alpha} = ${Elatin10::not_alpha};
519             ${Elatin10::not_ascii} = ${Elatin10::not_ascii};
520             ${Elatin10::not_blank} = ${Elatin10::not_blank};
521             ${Elatin10::not_cntrl} = ${Elatin10::not_cntrl};
522             ${Elatin10::not_digit} = ${Elatin10::not_digit};
523             ${Elatin10::not_graph} = ${Elatin10::not_graph};
524             ${Elatin10::not_lower} = ${Elatin10::not_lower};
525             ${Elatin10::not_lower_i} = ${Elatin10::not_lower_i};
526             ${Elatin10::not_print} = ${Elatin10::not_print};
527             ${Elatin10::not_punct} = ${Elatin10::not_punct};
528             ${Elatin10::not_space} = ${Elatin10::not_space};
529             ${Elatin10::not_upper} = ${Elatin10::not_upper};
530             ${Elatin10::not_upper_i} = ${Elatin10::not_upper_i};
531             ${Elatin10::not_word} = ${Elatin10::not_word};
532             ${Elatin10::not_xdigit} = ${Elatin10::not_xdigit};
533             ${Elatin10::eb} = ${Elatin10::eb};
534             ${Elatin10::eB} = ${Elatin10::eB};
535              
536             #
537             # Latin-10 split
538             #
539             sub Elatin10::split(;$$$) {
540              
541             # P.794 29.2.161. split
542             # in Chapter 29: Functions
543             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
544              
545             # P.951 split
546             # in Chapter 27: Functions
547             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
548              
549 0     0 0 0 my $pattern = $_[0];
550 0         0 my $string = $_[1];
551 0         0 my $limit = $_[2];
552              
553             # if $pattern is also omitted or is the literal space, " "
554 0 0       0 if (not defined $pattern) {
555 0         0 $pattern = ' ';
556             }
557              
558             # if $string is omitted, the function splits the $_ string
559 0 0       0 if (not defined $string) {
560 0 0       0 if (defined $_) {
561 0         0 $string = $_;
562             }
563             else {
564 0         0 $string = '';
565             }
566             }
567              
568 0         0 my @split = ();
569              
570             # when string is empty
571 0 0       0 if ($string eq '') {
    0          
572              
573             # resulting list value in list context
574 0 0       0 if (wantarray) {
575 0         0 return @split;
576             }
577              
578             # count of substrings in scalar context
579             else {
580 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
581 0         0 @_ = @split;
582 0         0 return scalar @_;
583             }
584             }
585              
586             # split's first argument is more consistently interpreted
587             #
588             # After some changes earlier in v5.17, split's behavior has been simplified:
589             # if the PATTERN argument evaluates to a string containing one space, it is
590             # treated the way that a literal string containing one space once was.
591             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
592              
593             # if $pattern is also omitted or is the literal space, " ", the function splits
594             # on whitespace, /\s+/, after skipping any leading whitespace
595             # (and so on)
596              
597             elsif ($pattern eq ' ') {
598 0 0       0 if (not defined $limit) {
599 0         0 return CORE::split(' ', $string);
600             }
601             else {
602 0         0 return CORE::split(' ', $string, $limit);
603             }
604             }
605              
606             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
607 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
608              
609             # a pattern capable of matching either the null string or something longer than the
610             # null string will split the value of $string into separate characters wherever it
611             # matches the null string between characters
612             # (and so on)
613              
614 0 0       0 if ('' =~ / \A $pattern \z /xms) {
615 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
616 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
617              
618             # P.1024 Appendix W.10 Multibyte Processing
619             # of ISBN 1-56592-224-7 CJKV Information Processing
620             # (and so on)
621              
622             # the //m modifier is assumed when you split on the pattern /^/
623             # (and so on)
624              
625             # V
626 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
627              
628             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
629             # is included in the resulting list, interspersed with the fields that are ordinarily returned
630             # (and so on)
631              
632 0         0 local $@;
633 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
634 0         0 push @split, CORE::eval('$' . $digit);
635             }
636             }
637             }
638              
639             else {
640 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
641              
642             # V
643 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
644 0         0 local $@;
645 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
646 0         0 push @split, CORE::eval('$' . $digit);
647             }
648             }
649             }
650             }
651              
652             elsif ($limit > 0) {
653 0 0       0 if ('' =~ / \A $pattern \z /xms) {
654 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
655 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
656              
657             # V
658 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
659 0         0 local $@;
660 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
661 0         0 push @split, CORE::eval('$' . $digit);
662             }
663             }
664             }
665             }
666             else {
667 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
668 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
669              
670             # V
671 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
672 0         0 local $@;
673 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
674 0         0 push @split, CORE::eval('$' . $digit);
675             }
676             }
677             }
678             }
679             }
680              
681 0 0       0 if (CORE::length($string) > 0) {
682 0         0 push @split, $string;
683             }
684              
685             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
686 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
687 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
688 0         0 pop @split;
689             }
690             }
691              
692             # resulting list value in list context
693 0 0       0 if (wantarray) {
694 0         0 return @split;
695             }
696              
697             # count of substrings in scalar context
698             else {
699 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
700 0         0 @_ = @split;
701 0         0 return scalar @_;
702             }
703             }
704              
705             #
706             # get last subexpression offsets
707             #
708             sub _last_subexpression_offsets {
709 0     0   0 my $pattern = $_[0];
710              
711             # remove comment
712 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
713              
714 0         0 my $modifier = '';
715 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
716 0         0 $modifier = $1;
717 0         0 $modifier =~ s/-[A-Za-z]*//;
718             }
719              
720             # with /x modifier
721 0         0 my @char = ();
722 0 0       0 if ($modifier =~ /x/oxms) {
723 0         0 @char = $pattern =~ /\G((?>
724             [^\\\#\[\(] |
725             \\ $q_char |
726             \# (?>[^\n]*) $ |
727             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
728             \(\? |
729             $q_char
730             ))/oxmsg;
731             }
732              
733             # without /x modifier
734             else {
735 0         0 @char = $pattern =~ /\G((?>
736             [^\\\[\(] |
737             \\ $q_char |
738             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
739             \(\? |
740             $q_char
741             ))/oxmsg;
742             }
743              
744 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
745             }
746              
747             #
748             # Latin-10 transliteration (tr///)
749             #
750             sub Elatin10::tr($$$$;$) {
751              
752 0     0 0 0 my $bind_operator = $_[1];
753 0         0 my $searchlist = $_[2];
754 0         0 my $replacementlist = $_[3];
755 0   0     0 my $modifier = $_[4] || '';
756              
757 0 0       0 if ($modifier =~ /r/oxms) {
758 0 0       0 if ($bind_operator =~ / !~ /oxms) {
759 0         0 croak "Using !~ with tr///r doesn't make sense";
760             }
761             }
762              
763 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
764 0         0 my @searchlist = _charlist_tr($searchlist);
765 0         0 my @replacementlist = _charlist_tr($replacementlist);
766              
767 0         0 my %tr = ();
768 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
769 0 0       0 if (not exists $tr{$searchlist[$i]}) {
770 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
771 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
772             }
773             elsif ($modifier =~ /d/oxms) {
774 0         0 $tr{$searchlist[$i]} = '';
775             }
776             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
777 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
778             }
779             else {
780 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
781             }
782             }
783             }
784              
785 0         0 my $tr = 0;
786 0         0 my $replaced = '';
787 0 0       0 if ($modifier =~ /c/oxms) {
788 0         0 while (defined(my $char = shift @char)) {
789 0 0       0 if (not exists $tr{$char}) {
790 0 0       0 if (defined $replacementlist[0]) {
791 0         0 $replaced .= $replacementlist[0];
792             }
793 0         0 $tr++;
794 0 0       0 if ($modifier =~ /s/oxms) {
795 0   0     0 while (@char and (not exists $tr{$char[0]})) {
796 0         0 shift @char;
797 0         0 $tr++;
798             }
799             }
800             }
801             else {
802 0         0 $replaced .= $char;
803             }
804             }
805             }
806             else {
807 0         0 while (defined(my $char = shift @char)) {
808 0 0       0 if (exists $tr{$char}) {
809 0         0 $replaced .= $tr{$char};
810 0         0 $tr++;
811 0 0       0 if ($modifier =~ /s/oxms) {
812 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
813 0         0 shift @char;
814 0         0 $tr++;
815             }
816             }
817             }
818             else {
819 0         0 $replaced .= $char;
820             }
821             }
822             }
823              
824 0 0       0 if ($modifier =~ /r/oxms) {
825 0         0 return $replaced;
826             }
827             else {
828 0         0 $_[0] = $replaced;
829 0 0       0 if ($bind_operator =~ / !~ /oxms) {
830 0         0 return not $tr;
831             }
832             else {
833 0         0 return $tr;
834             }
835             }
836             }
837              
838             #
839             # Latin-10 chop
840             #
841             sub Elatin10::chop(@) {
842              
843 0     0 0 0 my $chop;
844 0 0       0 if (@_ == 0) {
845 0         0 my @char = /\G (?>$q_char) /oxmsg;
846 0         0 $chop = pop @char;
847 0         0 $_ = join '', @char;
848             }
849             else {
850 0         0 for (@_) {
851 0         0 my @char = /\G (?>$q_char) /oxmsg;
852 0         0 $chop = pop @char;
853 0         0 $_ = join '', @char;
854             }
855             }
856 0         0 return $chop;
857             }
858              
859             #
860             # Latin-10 index by octet
861             #
862             sub Elatin10::index($$;$) {
863              
864 0     0 1 0 my($str,$substr,$position) = @_;
865 0   0     0 $position ||= 0;
866 0         0 my $pos = 0;
867              
868 0         0 while ($pos < CORE::length($str)) {
869 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
870 0 0       0 if ($pos >= $position) {
871 0         0 return $pos;
872             }
873             }
874 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
875 0         0 $pos += CORE::length($1);
876             }
877             else {
878 0         0 $pos += 1;
879             }
880             }
881 0         0 return -1;
882             }
883              
884             #
885             # Latin-10 reverse index
886             #
887             sub Elatin10::rindex($$;$) {
888              
889 0     0 0 0 my($str,$substr,$position) = @_;
890 0   0     0 $position ||= CORE::length($str) - 1;
891 0         0 my $pos = 0;
892 0         0 my $rindex = -1;
893              
894 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
895 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
896 0         0 $rindex = $pos;
897             }
898 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
899 0         0 $pos += CORE::length($1);
900             }
901             else {
902 0         0 $pos += 1;
903             }
904             }
905 0         0 return $rindex;
906             }
907              
908             #
909             # Latin-10 lower case first with parameter
910             #
911             sub Elatin10::lcfirst(@) {
912 0 0   0 0 0 if (@_) {
913 0         0 my $s = shift @_;
914 0 0 0     0 if (@_ and wantarray) {
915 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
916             }
917             else {
918 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
919             }
920             }
921             else {
922 0         0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
923             }
924             }
925              
926             #
927             # Latin-10 lower case first without parameter
928             #
929             sub Elatin10::lcfirst_() {
930 0     0 0 0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
931             }
932              
933             #
934             # Latin-10 lower case with parameter
935             #
936             sub Elatin10::lc(@) {
937 0 0   0 0 0 if (@_) {
938 0         0 my $s = shift @_;
939 0 0 0     0 if (@_ and wantarray) {
940 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
941             }
942             else {
943 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
944             }
945             }
946             else {
947 0         0 return Elatin10::lc_();
948             }
949             }
950              
951             #
952             # Latin-10 lower case without parameter
953             #
954             sub Elatin10::lc_() {
955 0     0 0 0 my $s = $_;
956 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
957             }
958              
959             #
960             # Latin-10 upper case first with parameter
961             #
962             sub Elatin10::ucfirst(@) {
963 0 0   0 0 0 if (@_) {
964 0         0 my $s = shift @_;
965 0 0 0     0 if (@_ and wantarray) {
966 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
967             }
968             else {
969 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
970             }
971             }
972             else {
973 0         0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
974             }
975             }
976              
977             #
978             # Latin-10 upper case first without parameter
979             #
980             sub Elatin10::ucfirst_() {
981 0     0 0 0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
982             }
983              
984             #
985             # Latin-10 upper case with parameter
986             #
987             sub Elatin10::uc(@) {
988 0 50   174 0 0 if (@_) {
989 174         272 my $s = shift @_;
990 174 50 33     222 if (@_ and wantarray) {
991 174 0       320 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
992             }
993             else {
994 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         651  
995             }
996             }
997             else {
998 174         660 return Elatin10::uc_();
999             }
1000             }
1001              
1002             #
1003             # Latin-10 upper case without parameter
1004             #
1005             sub Elatin10::uc_() {
1006 0     0 0 0 my $s = $_;
1007 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1008             }
1009              
1010             #
1011             # Latin-10 fold case with parameter
1012             #
1013             sub Elatin10::fc(@) {
1014 0 50   197 0 0 if (@_) {
1015 197         282 my $s = shift @_;
1016 197 50 33     237 if (@_ and wantarray) {
1017 197 0       344 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1018             }
1019             else {
1020 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         489  
1021             }
1022             }
1023             else {
1024 197         1073 return Elatin10::fc_();
1025             }
1026             }
1027              
1028             #
1029             # Latin-10 fold case without parameter
1030             #
1031             sub Elatin10::fc_() {
1032 0     0 0 0 my $s = $_;
1033 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1034             }
1035              
1036             #
1037             # Latin-10 regexp capture
1038             #
1039             {
1040             sub Elatin10::capture {
1041 0     0 1 0 return $_[0];
1042             }
1043             }
1044              
1045             #
1046             # Latin-10 regexp ignore case modifier
1047             #
1048             sub Elatin10::ignorecase {
1049              
1050 0     0 0 0 my @string = @_;
1051 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1052              
1053             # ignore case of $scalar or @array
1054 0         0 for my $string (@string) {
1055              
1056             # split regexp
1057 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1058              
1059             # unescape character
1060 0         0 for (my $i=0; $i <= $#char; $i++) {
1061 0 0       0 next if not defined $char[$i];
1062              
1063             # open character class [...]
1064 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1065 0         0 my $left = $i;
1066              
1067             # [] make die "unmatched [] in regexp ...\n"
1068              
1069 0 0       0 if ($char[$i+1] eq ']') {
1070 0         0 $i++;
1071             }
1072              
1073 0         0 while (1) {
1074 0 0       0 if (++$i > $#char) {
1075 0         0 croak "Unmatched [] in regexp";
1076             }
1077 0 0       0 if ($char[$i] eq ']') {
1078 0         0 my $right = $i;
1079 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1080              
1081             # escape character
1082 0         0 for my $char (@charlist) {
1083 0 0       0 if (0) {
1084             }
1085              
1086 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1087 0         0 $char = '\\' . $char;
1088             }
1089             }
1090              
1091             # [...]
1092 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1093              
1094 0         0 $i = $left;
1095 0         0 last;
1096             }
1097             }
1098             }
1099              
1100             # open character class [^...]
1101             elsif ($char[$i] eq '[^') {
1102 0         0 my $left = $i;
1103              
1104             # [^] make die "unmatched [] in regexp ...\n"
1105              
1106 0 0       0 if ($char[$i+1] eq ']') {
1107 0         0 $i++;
1108             }
1109              
1110 0         0 while (1) {
1111 0 0       0 if (++$i > $#char) {
1112 0         0 croak "Unmatched [] in regexp";
1113             }
1114 0 0       0 if ($char[$i] eq ']') {
1115 0         0 my $right = $i;
1116 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1117              
1118             # escape character
1119 0         0 for my $char (@charlist) {
1120 0 0       0 if (0) {
1121             }
1122              
1123 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1124 0         0 $char = '\\' . $char;
1125             }
1126             }
1127              
1128             # [^...]
1129 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1130              
1131 0         0 $i = $left;
1132 0         0 last;
1133             }
1134             }
1135             }
1136              
1137             # rewrite classic character class or escape character
1138             elsif (my $char = classic_character_class($char[$i])) {
1139 0         0 $char[$i] = $char;
1140             }
1141              
1142             # with /i modifier
1143             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1144 0         0 my $uc = Elatin10::uc($char[$i]);
1145 0         0 my $fc = Elatin10::fc($char[$i]);
1146 0 0       0 if ($uc ne $fc) {
1147 0 0       0 if (CORE::length($fc) == 1) {
1148 0         0 $char[$i] = '[' . $uc . $fc . ']';
1149             }
1150             else {
1151 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1152             }
1153             }
1154             }
1155             }
1156              
1157             # characterize
1158 0         0 for (my $i=0; $i <= $#char; $i++) {
1159 0 0       0 next if not defined $char[$i];
1160              
1161 0 0       0 if (0) {
1162             }
1163              
1164             # quote character before ? + * {
1165 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1166 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1167 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1168             }
1169             }
1170             }
1171              
1172 0         0 $string = join '', @char;
1173             }
1174              
1175             # make regexp string
1176 0         0 return @string;
1177             }
1178              
1179             #
1180             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1181             #
1182             sub Elatin10::classic_character_class {
1183 0     1867 0 0 my($char) = @_;
1184              
1185             return {
1186             '\D' => '${Elatin10::eD}',
1187             '\S' => '${Elatin10::eS}',
1188             '\W' => '${Elatin10::eW}',
1189             '\d' => '[0-9]',
1190              
1191             # Before Perl 5.6, \s only matched the five whitespace characters
1192             # tab, newline, form-feed, carriage return, and the space character
1193             # itself, which, taken together, is the character class [\t\n\f\r ].
1194              
1195             # Vertical tabs are now whitespace
1196             # \s in a regex now matches a vertical tab in all circumstances.
1197             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1198             # \t \n \v \f \r space
1199             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1200             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1201             '\s' => '\s',
1202              
1203             '\w' => '[0-9A-Z_a-z]',
1204             '\C' => '[\x00-\xFF]',
1205             '\X' => 'X',
1206              
1207             # \h \v \H \V
1208              
1209             # P.114 Character Class Shortcuts
1210             # in Chapter 7: In the World of Regular Expressions
1211             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1212              
1213             # P.357 13.2.3 Whitespace
1214             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1215             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1216             #
1217             # 0x00009 CHARACTER TABULATION h s
1218             # 0x0000a LINE FEED (LF) vs
1219             # 0x0000b LINE TABULATION v
1220             # 0x0000c FORM FEED (FF) vs
1221             # 0x0000d CARRIAGE RETURN (CR) vs
1222             # 0x00020 SPACE h s
1223              
1224             # P.196 Table 5-9. Alphanumeric regex metasymbols
1225             # in Chapter 5. Pattern Matching
1226             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1227              
1228             # (and so on)
1229              
1230             '\H' => '${Elatin10::eH}',
1231             '\V' => '${Elatin10::eV}',
1232             '\h' => '[\x09\x20]',
1233             '\v' => '[\x0A\x0B\x0C\x0D]',
1234             '\R' => '${Elatin10::eR}',
1235              
1236             # \N
1237             #
1238             # http://perldoc.perl.org/perlre.html
1239             # Character Classes and other Special Escapes
1240             # Any character but \n (experimental). Not affected by /s modifier
1241              
1242             '\N' => '${Elatin10::eN}',
1243              
1244             # \b \B
1245              
1246             # P.180 Boundaries: The \b and \B Assertions
1247             # in Chapter 5: Pattern Matching
1248             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1249              
1250             # P.219 Boundaries: The \b and \B Assertions
1251             # in Chapter 5: Pattern Matching
1252             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1253              
1254             # \b really means (?:(?<=\w)(?!\w)|(?
1255             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1256             '\b' => '${Elatin10::eb}',
1257              
1258             # \B really means (?:(?<=\w)(?=\w)|(?
1259             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1260             '\B' => '${Elatin10::eB}',
1261              
1262 1867   100     2501 }->{$char} || '';
1263             }
1264              
1265             #
1266             # prepare Latin-10 characters per length
1267             #
1268              
1269             # 1 octet characters
1270             my @chars1 = ();
1271             sub chars1 {
1272 1867 0   0 0 82704 if (@chars1) {
1273 0         0 return @chars1;
1274             }
1275 0 0       0 if (exists $range_tr{1}) {
1276 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1277 0         0 while (my @range = splice(@ranges,0,1)) {
1278 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1279 0         0 push @chars1, pack 'C', $oct0;
1280             }
1281             }
1282             }
1283 0         0 return @chars1;
1284             }
1285              
1286             # 2 octets characters
1287             my @chars2 = ();
1288             sub chars2 {
1289 0 0   0 0 0 if (@chars2) {
1290 0         0 return @chars2;
1291             }
1292 0 0       0 if (exists $range_tr{2}) {
1293 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1294 0         0 while (my @range = splice(@ranges,0,2)) {
1295 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1296 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1297 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1298             }
1299             }
1300             }
1301             }
1302 0         0 return @chars2;
1303             }
1304              
1305             # 3 octets characters
1306             my @chars3 = ();
1307             sub chars3 {
1308 0 0   0 0 0 if (@chars3) {
1309 0         0 return @chars3;
1310             }
1311 0 0       0 if (exists $range_tr{3}) {
1312 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1313 0         0 while (my @range = splice(@ranges,0,3)) {
1314 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1315 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1316 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1317 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1318             }
1319             }
1320             }
1321             }
1322             }
1323 0         0 return @chars3;
1324             }
1325              
1326             # 4 octets characters
1327             my @chars4 = ();
1328             sub chars4 {
1329 0 0   0 0 0 if (@chars4) {
1330 0         0 return @chars4;
1331             }
1332 0 0       0 if (exists $range_tr{4}) {
1333 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1334 0         0 while (my @range = splice(@ranges,0,4)) {
1335 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1336 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1337 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1338 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1339 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1340             }
1341             }
1342             }
1343             }
1344             }
1345             }
1346 0         0 return @chars4;
1347             }
1348              
1349             #
1350             # Latin-10 open character list for tr
1351             #
1352             sub _charlist_tr {
1353              
1354 0     0   0 local $_ = shift @_;
1355              
1356             # unescape character
1357 0         0 my @char = ();
1358 0         0 while (not /\G \z/oxmsgc) {
1359 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1360 0         0 push @char, '\-';
1361             }
1362             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1363 0         0 push @char, CORE::chr(oct $1);
1364             }
1365             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1366 0         0 push @char, CORE::chr(hex $1);
1367             }
1368             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1369 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1370             }
1371             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1372             push @char, {
1373             '\0' => "\0",
1374             '\n' => "\n",
1375             '\r' => "\r",
1376             '\t' => "\t",
1377             '\f' => "\f",
1378             '\b' => "\x08", # \b means backspace in character class
1379             '\a' => "\a",
1380             '\e' => "\e",
1381 0         0 }->{$1};
1382             }
1383             elsif (/\G \\ ($q_char) /oxmsgc) {
1384 0         0 push @char, $1;
1385             }
1386             elsif (/\G ($q_char) /oxmsgc) {
1387 0         0 push @char, $1;
1388             }
1389             }
1390              
1391             # join separated multiple-octet
1392 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1393              
1394             # unescape '-'
1395 0         0 my @i = ();
1396 0         0 for my $i (0 .. $#char) {
1397 0 0       0 if ($char[$i] eq '\-') {
    0          
1398 0         0 $char[$i] = '-';
1399             }
1400             elsif ($char[$i] eq '-') {
1401 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1402 0         0 push @i, $i;
1403             }
1404             }
1405             }
1406              
1407             # open character list (reverse for splice)
1408 0         0 for my $i (CORE::reverse @i) {
1409 0         0 my @range = ();
1410              
1411             # range error
1412 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1413 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1414             }
1415              
1416             # range of multiple-octet code
1417 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1418 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1419 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1420             }
1421             elsif (CORE::length($char[$i+1]) == 2) {
1422 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1423 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1424             }
1425             elsif (CORE::length($char[$i+1]) == 3) {
1426 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1427 0         0 push @range, chars2();
1428 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1429             }
1430             elsif (CORE::length($char[$i+1]) == 4) {
1431 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1432 0         0 push @range, chars2();
1433 0         0 push @range, chars3();
1434 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1435             }
1436             else {
1437 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1438             }
1439             }
1440             elsif (CORE::length($char[$i-1]) == 2) {
1441 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1442 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1443             }
1444             elsif (CORE::length($char[$i+1]) == 3) {
1445 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1446 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1447             }
1448             elsif (CORE::length($char[$i+1]) == 4) {
1449 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1450 0         0 push @range, chars3();
1451 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1452             }
1453             else {
1454 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1455             }
1456             }
1457             elsif (CORE::length($char[$i-1]) == 3) {
1458 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1459 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1460             }
1461             elsif (CORE::length($char[$i+1]) == 4) {
1462 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1463 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1464             }
1465             else {
1466 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1467             }
1468             }
1469             elsif (CORE::length($char[$i-1]) == 4) {
1470 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1471 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1472             }
1473             else {
1474 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1475             }
1476             }
1477             else {
1478 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1479             }
1480              
1481 0         0 splice @char, $i-1, 3, @range;
1482             }
1483              
1484 0         0 return @char;
1485             }
1486              
1487             #
1488             # Latin-10 open character class
1489             #
1490             sub _cc {
1491 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1492 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1493             }
1494             elsif (scalar(@_) == 1) {
1495 0         0 return sprintf('\x%02X',$_[0]);
1496             }
1497             elsif (scalar(@_) == 2) {
1498 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1499 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1500             }
1501             elsif ($_[0] == $_[1]) {
1502 0         0 return sprintf('\x%02X',$_[0]);
1503             }
1504             elsif (($_[0]+1) == $_[1]) {
1505 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1506             }
1507             else {
1508 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1509             }
1510             }
1511             else {
1512 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1513             }
1514             }
1515              
1516             #
1517             # Latin-10 octet range
1518             #
1519             sub _octets {
1520 0     182   0 my $length = shift @_;
1521              
1522 182 50       295 if ($length == 1) {
1523 182         390 my($a1) = unpack 'C', $_[0];
1524 182         500 my($z1) = unpack 'C', $_[1];
1525              
1526 182 50       337 if ($a1 > $z1) {
1527 182         380 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1528             }
1529              
1530 0 50       0 if ($a1 == $z1) {
    50          
1531 182         466 return sprintf('\x%02X',$a1);
1532             }
1533             elsif (($a1+1) == $z1) {
1534 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1535             }
1536             else {
1537 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1538             }
1539             }
1540             else {
1541 182         1410 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1542             }
1543             }
1544              
1545             #
1546             # Latin-10 range regexp
1547             #
1548             sub _range_regexp {
1549 0     182   0 my($length,$first,$last) = @_;
1550              
1551 182         397 my @range_regexp = ();
1552 182 50       244 if (not exists $range_tr{$length}) {
1553 182         463 return @range_regexp;
1554             }
1555              
1556 0         0 my @ranges = @{ $range_tr{$length} };
  182         297  
1557 182         448 while (my @range = splice(@ranges,0,$length)) {
1558 182         639 my $min = '';
1559 182         278 my $max = '';
1560 182         243 for (my $i=0; $i < $length; $i++) {
1561 182         460 $min .= pack 'C', $range[$i][0];
1562 182         785 $max .= pack 'C', $range[$i][-1];
1563             }
1564              
1565             # min___max
1566             # FIRST_____________LAST
1567             # (nothing)
1568              
1569 182 50 33     472 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1570             }
1571              
1572             # **********
1573             # min_________max
1574             # FIRST_____________LAST
1575             # **********
1576              
1577             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1578 182         1782 push @range_regexp, _octets($length,$first,$max,$min,$max);
1579             }
1580              
1581             # **********************
1582             # min________________max
1583             # FIRST_____________LAST
1584             # **********************
1585              
1586             elsif (($min eq $first) and ($max eq $last)) {
1587 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1588             }
1589              
1590             # *********
1591             # min___max
1592             # FIRST_____________LAST
1593             # *********
1594              
1595             elsif (($first le $min) and ($max le $last)) {
1596 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1597             }
1598              
1599             # **********************
1600             # min__________________________max
1601             # FIRST_____________LAST
1602             # **********************
1603              
1604             elsif (($min le $first) and ($last le $max)) {
1605 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1606             }
1607              
1608             # *********
1609             # min________max
1610             # FIRST_____________LAST
1611             # *********
1612              
1613             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1614 182         477 push @range_regexp, _octets($length,$min,$last,$min,$max);
1615             }
1616              
1617             # min___max
1618             # FIRST_____________LAST
1619             # (nothing)
1620              
1621             elsif ($last lt $min) {
1622             }
1623              
1624             else {
1625 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1626             }
1627             }
1628              
1629 0         0 return @range_regexp;
1630             }
1631              
1632             #
1633             # Latin-10 open character list for qr and not qr
1634             #
1635             sub _charlist {
1636              
1637 182     358   408 my $modifier = pop @_;
1638 358         592 my @char = @_;
1639              
1640 358 100       752 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1641              
1642             # unescape character
1643 358         874 for (my $i=0; $i <= $#char; $i++) {
1644              
1645             # escape - to ...
1646 358 100 100     1615 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1647 1125 100 100     8512 if ((0 < $i) and ($i < $#char)) {
1648 206         1946 $char[$i] = '...';
1649             }
1650             }
1651              
1652             # octal escape sequence
1653             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1654 182         429 $char[$i] = octchr($1);
1655             }
1656              
1657             # hexadecimal escape sequence
1658             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1659 0         0 $char[$i] = hexchr($1);
1660             }
1661              
1662             # \b{...} --> b\{...}
1663             # \B{...} --> B\{...}
1664             # \N{CHARNAME} --> N\{CHARNAME}
1665             # \p{PROPERTY} --> p\{PROPERTY}
1666             # \P{PROPERTY} --> P\{PROPERTY}
1667             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1668 0         0 $char[$i] = $1 . '\\' . $2;
1669             }
1670              
1671             # \p, \P, \X --> p, P, X
1672             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1673 0         0 $char[$i] = $1;
1674             }
1675              
1676             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1677 0         0 $char[$i] = CORE::chr oct $1;
1678             }
1679             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1680 0         0 $char[$i] = CORE::chr hex $1;
1681             }
1682             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1683 22         105 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1684             }
1685             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1686             $char[$i] = {
1687             '\0' => "\0",
1688             '\n' => "\n",
1689             '\r' => "\r",
1690             '\t' => "\t",
1691             '\f' => "\f",
1692             '\b' => "\x08", # \b means backspace in character class
1693             '\a' => "\a",
1694             '\e' => "\e",
1695             '\d' => '[0-9]',
1696              
1697             # Vertical tabs are now whitespace
1698             # \s in a regex now matches a vertical tab in all circumstances.
1699             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1700             # \t \n \v \f \r space
1701             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1702             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1703             '\s' => '\s',
1704              
1705             '\w' => '[0-9A-Z_a-z]',
1706             '\D' => '${Elatin10::eD}',
1707             '\S' => '${Elatin10::eS}',
1708             '\W' => '${Elatin10::eW}',
1709              
1710             '\H' => '${Elatin10::eH}',
1711             '\V' => '${Elatin10::eV}',
1712             '\h' => '[\x09\x20]',
1713             '\v' => '[\x0A\x0B\x0C\x0D]',
1714             '\R' => '${Elatin10::eR}',
1715              
1716 0         0 }->{$1};
1717             }
1718              
1719             # POSIX-style character classes
1720             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1721             $char[$i] = {
1722              
1723             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1724             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1725             '[:^lower:]' => '${Elatin10::not_lower_i}',
1726             '[:^upper:]' => '${Elatin10::not_upper_i}',
1727              
1728 25         411 }->{$1};
1729             }
1730             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1731             $char[$i] = {
1732              
1733             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1734             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1735             '[:ascii:]' => '[\x00-\x7F]',
1736             '[:blank:]' => '[\x09\x20]',
1737             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1738             '[:digit:]' => '[\x30-\x39]',
1739             '[:graph:]' => '[\x21-\x7F]',
1740             '[:lower:]' => '[\x61-\x7A]',
1741             '[:print:]' => '[\x20-\x7F]',
1742             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1743              
1744             # P.174 POSIX-Style Character Classes
1745             # in Chapter 5: Pattern Matching
1746             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1747              
1748             # P.311 11.2.4 Character Classes and other Special Escapes
1749             # in Chapter 11: perlre: Perl regular expressions
1750             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1751              
1752             # P.210 POSIX-Style Character Classes
1753             # in Chapter 5: Pattern Matching
1754             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1755              
1756             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1757              
1758             '[:upper:]' => '[\x41-\x5A]',
1759             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1760             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1761             '[:^alnum:]' => '${Elatin10::not_alnum}',
1762             '[:^alpha:]' => '${Elatin10::not_alpha}',
1763             '[:^ascii:]' => '${Elatin10::not_ascii}',
1764             '[:^blank:]' => '${Elatin10::not_blank}',
1765             '[:^cntrl:]' => '${Elatin10::not_cntrl}',
1766             '[:^digit:]' => '${Elatin10::not_digit}',
1767             '[:^graph:]' => '${Elatin10::not_graph}',
1768             '[:^lower:]' => '${Elatin10::not_lower}',
1769             '[:^print:]' => '${Elatin10::not_print}',
1770             '[:^punct:]' => '${Elatin10::not_punct}',
1771             '[:^space:]' => '${Elatin10::not_space}',
1772             '[:^upper:]' => '${Elatin10::not_upper}',
1773             '[:^word:]' => '${Elatin10::not_word}',
1774             '[:^xdigit:]' => '${Elatin10::not_xdigit}',
1775              
1776 8         62 }->{$1};
1777             }
1778             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1779 70         1197 $char[$i] = $1;
1780             }
1781             }
1782              
1783             # open character list
1784 7         39 my @singleoctet = ();
1785 358         615 my @multipleoctet = ();
1786 358         1253 for (my $i=0; $i <= $#char; ) {
1787              
1788             # escaped -
1789 358 100 100     894 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1790 943         3812 $i += 1;
1791 182         334 next;
1792             }
1793              
1794             # make range regexp
1795             elsif ($char[$i] eq '...') {
1796              
1797             # range error
1798 182 50       338 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1799 182         870 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1800             }
1801             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1802 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1803 182         458 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1804             }
1805             }
1806              
1807             # make range regexp per length
1808 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1809 182         534 my @regexp = ();
1810              
1811             # is first and last
1812 182 50 33     267 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1813 182         739 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1814             }
1815              
1816             # is first
1817             elsif ($length == CORE::length($char[$i-1])) {
1818 182         735 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1819             }
1820              
1821             # is inside in first and last
1822             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1823 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1824             }
1825              
1826             # is last
1827             elsif ($length == CORE::length($char[$i+1])) {
1828 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1829             }
1830              
1831             else {
1832 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1833             }
1834              
1835 0 50       0 if ($length == 1) {
1836 182         420 push @singleoctet, @regexp;
1837             }
1838             else {
1839 182         410 push @multipleoctet, @regexp;
1840             }
1841             }
1842              
1843 0         0 $i += 2;
1844             }
1845              
1846             # with /i modifier
1847             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1848 182 100       375 if ($modifier =~ /i/oxms) {
1849 493         733 my $uc = Elatin10::uc($char[$i]);
1850 24         51 my $fc = Elatin10::fc($char[$i]);
1851 24 100       56 if ($uc ne $fc) {
1852 24 50       51 if (CORE::length($fc) == 1) {
1853 12         21 push @singleoctet, $uc, $fc;
1854             }
1855             else {
1856 12         25 push @singleoctet, $uc;
1857 0         0 push @multipleoctet, $fc;
1858             }
1859             }
1860             else {
1861 0         0 push @singleoctet, $char[$i];
1862             }
1863             }
1864             else {
1865 12         32 push @singleoctet, $char[$i];
1866             }
1867 469         715 $i += 1;
1868             }
1869              
1870             # single character of single octet code
1871             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1872 493         784 push @singleoctet, "\t", "\x20";
1873 0         0 $i += 1;
1874             }
1875             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1876 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1877 0         0 $i += 1;
1878             }
1879             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1880 0         0 push @singleoctet, $char[$i];
1881 2         6 $i += 1;
1882             }
1883              
1884             # single character of multiple-octet code
1885             else {
1886 2         5 push @multipleoctet, $char[$i];
1887 84         158 $i += 1;
1888             }
1889             }
1890              
1891             # quote metachar
1892 84         155 for (@singleoctet) {
1893 358 50       724 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1894 689         3087 $_ = '-';
1895             }
1896             elsif (/\A \n \z/oxms) {
1897 0         0 $_ = '\n';
1898             }
1899             elsif (/\A \r \z/oxms) {
1900 8         22 $_ = '\r';
1901             }
1902             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1903 8         19 $_ = sprintf('\x%02X', CORE::ord $1);
1904             }
1905             elsif (/\A [\x00-\xFF] \z/oxms) {
1906 60         251 $_ = quotemeta $_;
1907             }
1908             }
1909              
1910             # return character list
1911 429         655 return \@singleoctet, \@multipleoctet;
1912             }
1913              
1914             #
1915             # Latin-10 octal escape sequence
1916             #
1917             sub octchr {
1918 358     5 0 2346 my($octdigit) = @_;
1919              
1920 5         13 my @binary = ();
1921 5         8 for my $octal (split(//,$octdigit)) {
1922             push @binary, {
1923             '0' => '000',
1924             '1' => '001',
1925             '2' => '010',
1926             '3' => '011',
1927             '4' => '100',
1928             '5' => '101',
1929             '6' => '110',
1930             '7' => '111',
1931 5         27 }->{$octal};
1932             }
1933 50         175 my $binary = join '', @binary;
1934              
1935             my $octchr = {
1936             # 1234567
1937             1 => pack('B*', "0000000$binary"),
1938             2 => pack('B*', "000000$binary"),
1939             3 => pack('B*', "00000$binary"),
1940             4 => pack('B*', "0000$binary"),
1941             5 => pack('B*', "000$binary"),
1942             6 => pack('B*', "00$binary"),
1943             7 => pack('B*', "0$binary"),
1944             0 => pack('B*', "$binary"),
1945              
1946 5         15 }->{CORE::length($binary) % 8};
1947              
1948 5         56 return $octchr;
1949             }
1950              
1951             #
1952             # Latin-10 hexadecimal escape sequence
1953             #
1954             sub hexchr {
1955 5     5 0 20 my($hexdigit) = @_;
1956              
1957             my $hexchr = {
1958             1 => pack('H*', "0$hexdigit"),
1959             0 => pack('H*', "$hexdigit"),
1960              
1961 5         12 }->{CORE::length($_[0]) % 2};
1962              
1963 5         35 return $hexchr;
1964             }
1965              
1966             #
1967             # Latin-10 open character list for qr
1968             #
1969             sub charlist_qr {
1970              
1971 5     314 0 19 my $modifier = pop @_;
1972 314         621 my @char = @_;
1973              
1974 314         876 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1975 314         1127 my @singleoctet = @$singleoctet;
1976 314         814 my @multipleoctet = @$multipleoctet;
1977              
1978             # return character list
1979 314 100       479 if (scalar(@singleoctet) >= 1) {
1980              
1981             # with /i modifier
1982 314 100       714 if ($modifier =~ m/i/oxms) {
1983 236         465 my %singleoctet_ignorecase = ();
1984 22         33 for (@singleoctet) {
1985 22   100     37 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1986 46         201 for my $ord (hex($1) .. hex($2)) {
1987 46         139 my $char = CORE::chr($ord);
1988 66         98 my $uc = Elatin10::uc($char);
1989 66         151 my $fc = Elatin10::fc($char);
1990 66 100       113 if ($uc eq $fc) {
1991 66         1197 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1992             }
1993             else {
1994 12 50       77 if (CORE::length($fc) == 1) {
1995 54         81 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1996 54         133 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1997             }
1998             else {
1999 54         201 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2000 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2001             }
2002             }
2003             }
2004             }
2005 0 50       0 if ($_ ne '') {
2006 46         96 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2007             }
2008             }
2009 0         0 my $i = 0;
2010 22         26 my @singleoctet_ignorecase = ();
2011 22         32 for my $ord (0 .. 255) {
2012 22 100       38 if (exists $singleoctet_ignorecase{$ord}) {
2013 5632         9097 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         99  
2014             }
2015             else {
2016 96         226 $i++;
2017             }
2018             }
2019 5536         9412 @singleoctet = ();
2020 22         40 for my $range (@singleoctet_ignorecase) {
2021 22 100       70 if (ref $range) {
2022 3648 100       7120 if (scalar(@{$range}) == 1) {
  56 50       54  
2023 56         88 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         40  
2024             }
2025 36         117 elsif (scalar(@{$range}) == 2) {
2026 20         28 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2027             }
2028             else {
2029 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         24  
  20         27  
2030             }
2031             }
2032             }
2033             }
2034              
2035 20         95 my $not_anchor = '';
2036              
2037 236         371 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2038             }
2039 236 100       682 if (scalar(@multipleoctet) >= 2) {
2040 314         676 return '(?:' . join('|', @multipleoctet) . ')';
2041             }
2042             else {
2043 6         44 return $multipleoctet[0];
2044             }
2045             }
2046              
2047             #
2048             # Latin-10 open character list for not qr
2049             #
2050             sub charlist_not_qr {
2051              
2052 308     44 0 1287 my $modifier = pop @_;
2053 44         87 my @char = @_;
2054              
2055 44         101 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2056 44         140 my @singleoctet = @$singleoctet;
2057 44         91 my @multipleoctet = @$multipleoctet;
2058              
2059             # with /i modifier
2060 44 100       70 if ($modifier =~ m/i/oxms) {
2061 44         117 my %singleoctet_ignorecase = ();
2062 10         13 for (@singleoctet) {
2063 10   66     13 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2064 10         47 for my $ord (hex($1) .. hex($2)) {
2065 10         30 my $char = CORE::chr($ord);
2066 30         40 my $uc = Elatin10::uc($char);
2067 30         44 my $fc = Elatin10::fc($char);
2068 30 50       49 if ($uc eq $fc) {
2069 30         58 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2070             }
2071             else {
2072 0 50       0 if (CORE::length($fc) == 1) {
2073 30         39 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2074 30         66 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2075             }
2076             else {
2077 30         97 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2078 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2079             }
2080             }
2081             }
2082             }
2083 0 50       0 if ($_ ne '') {
2084 10         28 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2085             }
2086             }
2087 0         0 my $i = 0;
2088 10         12 my @singleoctet_ignorecase = ();
2089 10         15 for my $ord (0 .. 255) {
2090 10 100       15 if (exists $singleoctet_ignorecase{$ord}) {
2091 2560         2898 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         57  
2092             }
2093             else {
2094 60         93 $i++;
2095             }
2096             }
2097 2500         2488 @singleoctet = ();
2098 10         13 for my $range (@singleoctet_ignorecase) {
2099 10 100       23 if (ref $range) {
2100 960 50       1424 if (scalar(@{$range}) == 1) {
  20 50       20  
2101 20         27 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2102             }
2103 0         0 elsif (scalar(@{$range}) == 2) {
2104 20         29 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2105             }
2106             else {
2107 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         23  
2108             }
2109             }
2110             }
2111             }
2112              
2113             # return character list
2114 20 50       74 if (scalar(@multipleoctet) >= 1) {
2115 44 0       108 if (scalar(@singleoctet) >= 1) {
2116              
2117             # any character other than multiple-octet and single octet character class
2118 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2119             }
2120             else {
2121              
2122             # any character other than multiple-octet character class
2123 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2124             }
2125             }
2126             else {
2127 0 50       0 if (scalar(@singleoctet) >= 1) {
2128              
2129             # any character other than single octet character class
2130 44         96 return '(?:[^' . join('', @singleoctet) . '])';
2131             }
2132             else {
2133              
2134             # any character
2135 44         259 return "(?:$your_char)";
2136             }
2137             }
2138             }
2139              
2140             #
2141             # open file in read mode
2142             #
2143             sub _open_r {
2144 0     408   0 my(undef,$file) = @_;
2145 204     204   2274 use Fcntl qw(O_RDONLY);
  204         509  
  204         42510  
2146 408         1160 return CORE::sysopen($_[0], $file, &O_RDONLY);
2147             }
2148              
2149             #
2150             # open file in append mode
2151             #
2152             sub _open_a {
2153 408     204   16994 my(undef,$file) = @_;
2154 204     204   18882 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         602  
  204         681274  
2155 204         628 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2156             }
2157              
2158             #
2159             # safe system
2160             #
2161             sub _systemx {
2162              
2163             # P.707 29.2.33. exec
2164             # in Chapter 29: Functions
2165             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2166             #
2167             # Be aware that in older releases of Perl, exec (and system) did not flush
2168             # your output buffer, so you needed to enable command buffering by setting $|
2169             # on one or more filehandles to avoid lost output in the case of exec, or
2170             # misordererd output in the case of system. This situation was largely remedied
2171             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2172              
2173             # P.855 exec
2174             # in Chapter 27: Functions
2175             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2176             #
2177             # In very old release of Perl (before v5.6), exec (and system) did not flush
2178             # your output buffer, so you needed to enable command buffering by setting $|
2179             # on one or more filehandles to avoid lost output with exec or misordered
2180             # output with system.
2181              
2182 204     204   28441 $| = 1;
2183              
2184             # P.565 23.1.2. Cleaning Up Your Environment
2185             # in Chapter 23: Security
2186             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2187              
2188             # P.656 Cleaning Up Your Environment
2189             # in Chapter 20: Security
2190             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2191              
2192             # local $ENV{'PATH'} = '.';
2193 204         692 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2194              
2195             # P.707 29.2.33. exec
2196             # in Chapter 29: Functions
2197             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2198             #
2199             # As we mentioned earlier, exec treats a discrete list of arguments as an
2200             # indication that it should bypass shell processing. However, there is one
2201             # place where you might still get tripped up. The exec call (and system, too)
2202             # will not distinguish between a single scalar argument and an array containing
2203             # only one element.
2204             #
2205             # @args = ("echo surprise"); # just one element in list
2206             # exec @args # still subject to shell escapes
2207             # or die "exec: $!"; # because @args == 1
2208             #
2209             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2210             # first argument as the pathname, which forces the rest of the arguments to be
2211             # interpreted as a list, even if there is only one of them:
2212             #
2213             # exec { $args[0] } @args # safe even with one-argument list
2214             # or die "can't exec @args: $!";
2215              
2216             # P.855 exec
2217             # in Chapter 27: Functions
2218             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2219             #
2220             # As we mentioned earlier, exec treats a discrete list of arguments as a
2221             # directive to bypass shell processing. However, there is one place where
2222             # you might still get tripped up. The exec call (and system, too) cannot
2223             # distinguish between a single scalar argument and an array containing
2224             # only one element.
2225             #
2226             # @args = ("echo surprise"); # just one element in list
2227             # exec @args # still subject to shell escapes
2228             # || die "exec: $!"; # because @args == 1
2229             #
2230             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2231             # argument as the pathname, which forces the rest of the arguments to be
2232             # interpreted as a list, even if there is only one of them:
2233             #
2234             # exec { $args[0] } @args # safe even with one-argument list
2235             # || die "can't exec @args: $!";
2236              
2237 204         1870 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         522  
2238             }
2239              
2240             #
2241             # Latin-10 order to character (with parameter)
2242             #
2243             sub Elatin10::chr(;$) {
2244              
2245 204 0   0 0 19614390 my $c = @_ ? $_[0] : $_;
2246              
2247 0 0       0 if ($c == 0x00) {
2248 0         0 return "\x00";
2249             }
2250             else {
2251 0         0 my @chr = ();
2252 0         0 while ($c > 0) {
2253 0         0 unshift @chr, ($c % 0x100);
2254 0         0 $c = int($c / 0x100);
2255             }
2256 0         0 return pack 'C*', @chr;
2257             }
2258             }
2259              
2260             #
2261             # Latin-10 order to character (without parameter)
2262             #
2263             sub Elatin10::chr_() {
2264              
2265 0     0 0 0 my $c = $_;
2266              
2267 0 0       0 if ($c == 0x00) {
2268 0         0 return "\x00";
2269             }
2270             else {
2271 0         0 my @chr = ();
2272 0         0 while ($c > 0) {
2273 0         0 unshift @chr, ($c % 0x100);
2274 0         0 $c = int($c / 0x100);
2275             }
2276 0         0 return pack 'C*', @chr;
2277             }
2278             }
2279              
2280             #
2281             # Latin-10 path globbing (with parameter)
2282             #
2283             sub Elatin10::glob($) {
2284              
2285 0 0   0 0 0 if (wantarray) {
2286 0         0 my @glob = _DOS_like_glob(@_);
2287 0         0 for my $glob (@glob) {
2288 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2289             }
2290 0         0 return @glob;
2291             }
2292             else {
2293 0         0 my $glob = _DOS_like_glob(@_);
2294 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2295 0         0 return $glob;
2296             }
2297             }
2298              
2299             #
2300             # Latin-10 path globbing (without parameter)
2301             #
2302             sub Elatin10::glob_() {
2303              
2304 0 0   0 0 0 if (wantarray) {
2305 0         0 my @glob = _DOS_like_glob();
2306 0         0 for my $glob (@glob) {
2307 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2308             }
2309 0         0 return @glob;
2310             }
2311             else {
2312 0         0 my $glob = _DOS_like_glob();
2313 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2314 0         0 return $glob;
2315             }
2316             }
2317              
2318             #
2319             # Latin-10 path globbing via File::DosGlob 1.10
2320             #
2321             # Often I confuse "_dosglob" and "_doglob".
2322             # So, I renamed "_dosglob" to "_DOS_like_glob".
2323             #
2324             my %iter;
2325             my %entries;
2326             sub _DOS_like_glob {
2327              
2328             # context (keyed by second cxix argument provided by core)
2329 0     0   0 my($expr,$cxix) = @_;
2330              
2331             # glob without args defaults to $_
2332 0 0       0 $expr = $_ if not defined $expr;
2333              
2334             # represents the current user's home directory
2335             #
2336             # 7.3. Expanding Tildes in Filenames
2337             # in Chapter 7. File Access
2338             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2339             #
2340             # and File::HomeDir, File::HomeDir::Windows module
2341              
2342             # DOS-like system
2343 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2344 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2345             { my_home_MSWin32() }oxmse;
2346             }
2347              
2348             # UNIX-like system
2349 0 0 0     0 else {
  0         0  
2350             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2351             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2352             }
2353 0 0       0  
2354 0 0       0 # assume global context if not provided one
2355             $cxix = '_G_' if not defined $cxix;
2356             $iter{$cxix} = 0 if not exists $iter{$cxix};
2357 0 0       0  
2358 0         0 # if we're just beginning, do it all first
2359             if ($iter{$cxix} == 0) {
2360             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2361             }
2362 0 0       0  
2363 0         0 # chuck it all out, quick or slow
2364 0         0 if (wantarray) {
  0         0  
2365             delete $iter{$cxix};
2366             return @{delete $entries{$cxix}};
2367 0 0       0 }
  0         0  
2368 0         0 else {
  0         0  
2369             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2370             return shift @{$entries{$cxix}};
2371             }
2372 0         0 else {
2373 0         0 # return undef for EOL
2374 0         0 delete $iter{$cxix};
2375             delete $entries{$cxix};
2376             return undef;
2377             }
2378             }
2379             }
2380              
2381             #
2382             # Latin-10 path globbing subroutine
2383             #
2384 0     0   0 sub _do_glob {
2385 0         0  
2386 0         0 my($cond,@expr) = @_;
2387             my @glob = ();
2388             my $fix_drive_relative_paths = 0;
2389 0         0  
2390 0 0       0 OUTER:
2391 0 0       0 for my $expr (@expr) {
2392             next OUTER if not defined $expr;
2393 0         0 next OUTER if $expr eq '';
2394 0         0  
2395 0         0 my @matched = ();
2396 0         0 my @globdir = ();
2397 0         0 my $head = '.';
2398             my $pathsep = '/';
2399             my $tail;
2400 0 0       0  
2401 0         0 # if argument is within quotes strip em and do no globbing
2402 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2403 0 0       0 $expr = $1;
2404 0         0 if ($cond eq 'd') {
2405             if (-d $expr) {
2406             push @glob, $expr;
2407             }
2408 0 0       0 }
2409 0         0 else {
2410             if (-e $expr) {
2411             push @glob, $expr;
2412 0         0 }
2413             }
2414             next OUTER;
2415             }
2416              
2417 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2418 0 0       0 # to h:./*.pm to expand correctly
2419 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2420             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2421             $fix_drive_relative_paths = 1;
2422             }
2423 0 0       0 }
2424 0 0       0  
2425 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2426 0         0 if ($tail eq '') {
2427             push @glob, $expr;
2428 0 0       0 next OUTER;
2429 0 0       0 }
2430 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2431 0         0 if (@globdir = _do_glob('d', $head)) {
2432             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2433             next OUTER;
2434 0 0 0     0 }
2435 0         0 }
2436             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2437 0         0 $head .= $pathsep;
2438             }
2439             $expr = $tail;
2440             }
2441 0 0       0  
2442 0 0       0 # If file component has no wildcards, we can avoid opendir
2443 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2444             if ($head eq '.') {
2445 0 0 0     0 $head = '';
2446 0         0 }
2447             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2448 0         0 $head .= $pathsep;
2449 0 0       0 }
2450 0 0       0 $head .= $expr;
2451 0         0 if ($cond eq 'd') {
2452             if (-d $head) {
2453             push @glob, $head;
2454             }
2455 0 0       0 }
2456 0         0 else {
2457             if (-e $head) {
2458             push @glob, $head;
2459 0         0 }
2460             }
2461 0 0       0 next OUTER;
2462 0         0 }
2463 0         0 opendir(*DIR, $head) or next OUTER;
2464             my @leaf = readdir DIR;
2465 0 0       0 closedir DIR;
2466 0         0  
2467             if ($head eq '.') {
2468 0 0 0     0 $head = '';
2469 0         0 }
2470             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2471             $head .= $pathsep;
2472 0         0 }
2473 0         0  
2474 0         0 my $pattern = '';
2475             while ($expr =~ / \G ($q_char) /oxgc) {
2476             my $char = $1;
2477              
2478             # 6.9. Matching Shell Globs as Regular Expressions
2479             # in Chapter 6. Pattern Matching
2480             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2481 0 0       0 # (and so on)
    0          
    0          
2482 0         0  
2483             if ($char eq '*') {
2484             $pattern .= "(?:$your_char)*",
2485 0         0 }
2486             elsif ($char eq '?') {
2487             $pattern .= "(?:$your_char)?", # DOS style
2488             # $pattern .= "(?:$your_char)", # UNIX style
2489 0         0 }
2490             elsif ((my $fc = Elatin10::fc($char)) ne $char) {
2491             $pattern .= $fc;
2492 0         0 }
2493             else {
2494             $pattern .= quotemeta $char;
2495 0     0   0 }
  0         0  
2496             }
2497             my $matchsub = sub { Elatin10::fc($_[0]) =~ /\A $pattern \z/xms };
2498              
2499             # if ($@) {
2500             # print STDERR "$0: $@\n";
2501             # next OUTER;
2502             # }
2503 0         0  
2504 0 0 0     0 INNER:
2505 0         0 for my $leaf (@leaf) {
2506             if ($leaf eq '.' or $leaf eq '..') {
2507 0 0 0     0 next INNER;
2508 0         0 }
2509             if ($cond eq 'd' and not -d "$head$leaf") {
2510             next INNER;
2511 0 0       0 }
2512 0         0  
2513 0         0 if (&$matchsub($leaf)) {
2514             push @matched, "$head$leaf";
2515             next INNER;
2516             }
2517              
2518             # [DOS compatibility special case]
2519 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2520              
2521             if (Elatin10::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2522             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2523 0 0       0 Elatin10::index($pattern,'\\.') != -1 # pattern has a dot.
2524 0         0 ) {
2525 0         0 if (&$matchsub("$leaf.")) {
2526             push @matched, "$head$leaf";
2527             next INNER;
2528             }
2529 0 0       0 }
2530 0         0 }
2531             if (@matched) {
2532             push @glob, @matched;
2533 0 0       0 }
2534 0         0 }
2535 0         0 if ($fix_drive_relative_paths) {
2536             for my $glob (@glob) {
2537             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2538 0         0 }
2539             }
2540             return @glob;
2541             }
2542              
2543             #
2544             # Latin-10 parse line
2545             #
2546 0     0   0 sub _parse_line {
2547              
2548 0         0 my($line) = @_;
2549 0         0  
2550 0         0 $line .= ' ';
2551             my @piece = ();
2552             while ($line =~ /
2553             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2554             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2555 0 0       0 /oxmsg
2556             ) {
2557 0         0 push @piece, defined($1) ? $1 : $2;
2558             }
2559             return @piece;
2560             }
2561              
2562             #
2563             # Latin-10 parse path
2564             #
2565 0     0   0 sub _parse_path {
2566              
2567 0         0 my($path,$pathsep) = @_;
2568 0         0  
2569 0         0 $path .= '/';
2570             my @subpath = ();
2571             while ($path =~ /
2572             ((?: [^\/\\] )+?) [\/\\]
2573 0         0 /oxmsg
2574             ) {
2575             push @subpath, $1;
2576 0         0 }
2577 0         0  
2578 0         0 my $tail = pop @subpath;
2579             my $head = join $pathsep, @subpath;
2580             return $head, $tail;
2581             }
2582              
2583             #
2584             # via File::HomeDir::Windows 1.00
2585             #
2586             sub my_home_MSWin32 {
2587              
2588             # A lot of unix people and unix-derived tools rely on
2589 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2590 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2591             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2592             return $ENV{'HOME'};
2593             }
2594              
2595 0         0 # Do we have a user profile?
2596             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2597             return $ENV{'USERPROFILE'};
2598             }
2599              
2600 0         0 # Some Windows use something like $ENV{'HOME'}
2601             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2602             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2603 0         0 }
2604              
2605             return undef;
2606             }
2607              
2608             #
2609             # via File::HomeDir::Unix 1.00
2610 0     0 0 0 #
2611             sub my_home {
2612 0 0 0     0 my $home;
    0 0        
2613 0         0  
2614             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2615             $home = $ENV{'HOME'};
2616             }
2617              
2618             # This is from the original code, but I'm guessing
2619 0         0 # it means "login directory" and exists on some Unixes.
2620             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2621             $home = $ENV{'LOGDIR'};
2622             }
2623              
2624             ### More-desperate methods
2625              
2626 0         0 # Light desperation on any (Unixish) platform
2627             else {
2628             $home = CORE::eval q{ (getpwuid($<))[7] };
2629             }
2630              
2631 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2632 0         0 # For example, "nobody"-like users might use /nonexistant
2633             if (defined $home and ! -d($home)) {
2634 0         0 $home = undef;
2635             }
2636             return $home;
2637             }
2638              
2639             #
2640             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2641 0     0 0 0 #
2642             sub Elatin10::PREMATCH {
2643             return $`;
2644             }
2645              
2646             #
2647             # ${^MATCH}, $MATCH, $& the string that matched
2648 0     0 0 0 #
2649             sub Elatin10::MATCH {
2650             return $&;
2651             }
2652              
2653             #
2654             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2655 0     0 0 0 #
2656             sub Elatin10::POSTMATCH {
2657             return $';
2658             }
2659              
2660             #
2661             # Latin-10 character to order (with parameter)
2662             #
2663 0 0   0 1 0 sub Latin10::ord(;$) {
2664              
2665 0 0       0 local $_ = shift if @_;
2666 0         0  
2667 0         0 if (/\A ($q_char) /oxms) {
2668 0         0 my @ord = unpack 'C*', $1;
2669 0         0 my $ord = 0;
2670             while (my $o = shift @ord) {
2671 0         0 $ord = $ord * 0x100 + $o;
2672             }
2673             return $ord;
2674 0         0 }
2675             else {
2676             return CORE::ord $_;
2677             }
2678             }
2679              
2680             #
2681             # Latin-10 character to order (without parameter)
2682             #
2683 0 0   0 0 0 sub Latin10::ord_() {
2684 0         0  
2685 0         0 if (/\A ($q_char) /oxms) {
2686 0         0 my @ord = unpack 'C*', $1;
2687 0         0 my $ord = 0;
2688             while (my $o = shift @ord) {
2689 0         0 $ord = $ord * 0x100 + $o;
2690             }
2691             return $ord;
2692 0         0 }
2693             else {
2694             return CORE::ord $_;
2695             }
2696             }
2697              
2698             #
2699             # Latin-10 reverse
2700             #
2701 0 0   0 0 0 sub Latin10::reverse(@) {
2702 0         0  
2703             if (wantarray) {
2704             return CORE::reverse @_;
2705             }
2706             else {
2707              
2708             # One of us once cornered Larry in an elevator and asked him what
2709             # problem he was solving with this, but he looked as far off into
2710             # the distance as he could in an elevator and said, "It seemed like
2711 0         0 # a good idea at the time."
2712              
2713             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2714             }
2715             }
2716              
2717             #
2718             # Latin-10 getc (with parameter, without parameter)
2719             #
2720 0     0 0 0 sub Latin10::getc(;*@) {
2721 0 0       0  
2722 0 0 0     0 my($package) = caller;
2723             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2724 0         0 croak 'Too many arguments for Latin10::getc' if @_ and not wantarray;
  0         0  
2725 0         0  
2726 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2727 0         0 my $getc = '';
2728 0 0       0 for my $length ($length[0] .. $length[-1]) {
2729 0 0       0 $getc .= CORE::getc($fh);
2730 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2731             if ($getc =~ /\A ${Elatin10::dot_s} \z/oxms) {
2732             return wantarray ? ($getc,@_) : $getc;
2733             }
2734 0 0       0 }
2735             }
2736             return wantarray ? ($getc,@_) : $getc;
2737             }
2738              
2739             #
2740             # Latin-10 length by character
2741             #
2742 0 0   0 1 0 sub Latin10::length(;$) {
2743              
2744 0         0 local $_ = shift if @_;
2745 0         0  
2746             local @_ = /\G ($q_char) /oxmsg;
2747             return scalar @_;
2748             }
2749              
2750             #
2751             # Latin-10 substr by character
2752             #
2753             BEGIN {
2754              
2755             # P.232 The lvalue Attribute
2756             # in Chapter 6: Subroutines
2757             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2758              
2759             # P.336 The lvalue Attribute
2760             # in Chapter 7: Subroutines
2761             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2762              
2763             # P.144 8.4 Lvalue subroutines
2764             # in Chapter 8: perlsub: Perl subroutines
2765 204 50 0 204 1 142389 # 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  
2766              
2767             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2768             # vv----------------------*******
2769             sub Latin10::substr($$;$$) %s {
2770              
2771             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2772              
2773             # If the substring is beyond either end of the string, substr() returns the undefined
2774             # value and produces a warning. When used as an lvalue, specifying a substring that
2775             # is entirely outside the string raises an exception.
2776             # http://perldoc.perl.org/functions/substr.html
2777              
2778             # A return with no argument returns the scalar value undef in scalar context,
2779             # an empty list () in list context, and (naturally) nothing at all in void
2780             # context.
2781              
2782             my $offset = $_[1];
2783             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2784             return;
2785             }
2786              
2787             # substr($string,$offset,$length,$replacement)
2788             if (@_ == 4) {
2789             my(undef,undef,$length,$replacement) = @_;
2790             my $substr = join '', splice(@char, $offset, $length, $replacement);
2791             $_[0] = join '', @char;
2792              
2793             # return $substr; this doesn't work, don't say "return"
2794             $substr;
2795             }
2796              
2797             # substr($string,$offset,$length)
2798             elsif (@_ == 3) {
2799             my(undef,undef,$length) = @_;
2800             my $octet_offset = 0;
2801             my $octet_length = 0;
2802             if ($offset == 0) {
2803             $octet_offset = 0;
2804             }
2805             elsif ($offset > 0) {
2806             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2807             }
2808             else {
2809             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2810             }
2811             if ($length == 0) {
2812             $octet_length = 0;
2813             }
2814             elsif ($length > 0) {
2815             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2816             }
2817             else {
2818             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2819             }
2820             CORE::substr($_[0], $octet_offset, $octet_length);
2821             }
2822              
2823             # substr($string,$offset)
2824             else {
2825             my $octet_offset = 0;
2826             if ($offset == 0) {
2827             $octet_offset = 0;
2828             }
2829             elsif ($offset > 0) {
2830             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2831             }
2832             else {
2833             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2834             }
2835             CORE::substr($_[0], $octet_offset);
2836             }
2837             }
2838             END
2839             }
2840              
2841             #
2842             # Latin-10 index by character
2843             #
2844 0     0 1 0 sub Latin10::index($$;$) {
2845 0 0       0  
2846 0         0 my $index;
2847             if (@_ == 3) {
2848             $index = Elatin10::index($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2849 0         0 }
2850             else {
2851             $index = Elatin10::index($_[0], $_[1]);
2852 0 0       0 }
2853 0         0  
2854             if ($index == -1) {
2855             return -1;
2856 0         0 }
2857             else {
2858             return Latin10::length(CORE::substr $_[0], 0, $index);
2859             }
2860             }
2861              
2862             #
2863             # Latin-10 rindex by character
2864             #
2865 0     0 1 0 sub Latin10::rindex($$;$) {
2866 0 0       0  
2867 0         0 my $rindex;
2868             if (@_ == 3) {
2869             $rindex = Elatin10::rindex($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2870 0         0 }
2871             else {
2872             $rindex = Elatin10::rindex($_[0], $_[1]);
2873 0 0       0 }
2874 0         0  
2875             if ($rindex == -1) {
2876             return -1;
2877 0         0 }
2878             else {
2879             return Latin10::length(CORE::substr $_[0], 0, $rindex);
2880             }
2881             }
2882              
2883 204     204   1893 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         444  
  204         22758  
2884             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2885             use vars qw($slash); $slash = 'm//';
2886              
2887             # ord() to ord() or Latin10::ord()
2888             my $function_ord = 'ord';
2889              
2890             # ord to ord or Latin10::ord_
2891             my $function_ord_ = 'ord';
2892              
2893             # reverse to reverse or Latin10::reverse
2894             my $function_reverse = 'reverse';
2895              
2896             # getc to getc or Latin10::getc
2897             my $function_getc = 'getc';
2898              
2899             # P.1023 Appendix W.9 Multibyte Anchoring
2900             # of ISBN 1-56592-224-7 CJKV Information Processing
2901              
2902 204     204   1678 my $anchor = '';
  204     0   370  
  204         9450916  
2903              
2904             use vars qw($nest);
2905              
2906             # regexp of nested parens in qqXX
2907              
2908             # P.340 Matching Nested Constructs with Embedded Code
2909             # in Chapter 7: Perl
2910             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2911              
2912             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2913             [^\\()] |
2914             \( (?{$nest++}) |
2915             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2916             \\ [^c] |
2917             \\c[\x40-\x5F] |
2918             [\x00-\xFF]
2919             }xms;
2920              
2921             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2922             [^\\{}] |
2923             \{ (?{$nest++}) |
2924             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2925             \\ [^c] |
2926             \\c[\x40-\x5F] |
2927             [\x00-\xFF]
2928             }xms;
2929              
2930             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2931             [^\\\[\]] |
2932             \[ (?{$nest++}) |
2933             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2934             \\ [^c] |
2935             \\c[\x40-\x5F] |
2936             [\x00-\xFF]
2937             }xms;
2938              
2939             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2940             [^\\<>] |
2941             \< (?{$nest++}) |
2942             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2943             \\ [^c] |
2944             \\c[\x40-\x5F] |
2945             [\x00-\xFF]
2946             }xms;
2947              
2948             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2949             (?: ::)? (?:
2950             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2951             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2952             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2953             ))
2954             }xms;
2955              
2956             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2957             (?: ::)? (?:
2958             (?>[0-9]+) |
2959             [^a-zA-Z_0-9\[\]] |
2960             ^[A-Z] |
2961             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2962             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2963             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2964             ))
2965             }xms;
2966              
2967             my $qq_substr = qr{(?> Char::substr | Latin10::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2968             }xms;
2969              
2970             # regexp of nested parens in qXX
2971             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2972             [^()] |
2973             \( (?{$nest++}) |
2974             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2975             [\x00-\xFF]
2976             }xms;
2977              
2978             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2979             [^\{\}] |
2980             \{ (?{$nest++}) |
2981             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2982             [\x00-\xFF]
2983             }xms;
2984              
2985             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2986             [^\[\]] |
2987             \[ (?{$nest++}) |
2988             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2989             [\x00-\xFF]
2990             }xms;
2991              
2992             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2993             [^<>] |
2994             \< (?{$nest++}) |
2995             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2996             [\x00-\xFF]
2997             }xms;
2998              
2999             my $matched = '';
3000             my $s_matched = '';
3001              
3002             my $tr_variable = ''; # variable of tr///
3003             my $sub_variable = ''; # variable of s///
3004             my $bind_operator = ''; # =~ or !~
3005              
3006             my @heredoc = (); # here document
3007             my @heredoc_delimiter = ();
3008             my $here_script = ''; # here script
3009              
3010             #
3011             # escape Latin-10 script
3012 0 50   204 0 0 #
3013             sub Latin10::escape(;$) {
3014             local($_) = $_[0] if @_;
3015              
3016             # P.359 The Study Function
3017             # in Chapter 7: Perl
3018 204         2002 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3019              
3020             study $_; # Yes, I studied study yesterday.
3021              
3022             # while all script
3023              
3024             # 6.14. Matching from Where the Last Pattern Left Off
3025             # in Chapter 6. Pattern Matching
3026             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3027             # (and so on)
3028              
3029             # one member of Tag-team
3030             #
3031             # P.128 Start of match (or end of previous match): \G
3032             # P.130 Advanced Use of \G with Perl
3033             # in Chapter 3: Overview of Regular Expression Features and Flavors
3034             # P.255 Use leading anchors
3035             # P.256 Expose ^ and \G at the front expressions
3036             # in Chapter 6: Crafting an Efficient Expression
3037             # P.315 "Tag-team" matching with /gc
3038             # in Chapter 7: Perl
3039 204         865 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3040 204         363  
3041 204         747 my $e_script = '';
3042             while (not /\G \z/oxgc) { # member
3043             $e_script .= Latin10::escape_token();
3044 75131         117862 }
3045              
3046             return $e_script;
3047             }
3048              
3049             #
3050             # escape Latin-10 token of script
3051             #
3052             sub Latin10::escape_token {
3053              
3054 204     75131 0 2679 # \n output here document
3055              
3056             my $ignore_modules = join('|', qw(
3057             utf8
3058             bytes
3059             charnames
3060             I18N::Japanese
3061             I18N::Collate
3062             I18N::JExt
3063             File::DosGlob
3064             Wild
3065             Wildcard
3066             Japanese
3067             ));
3068              
3069             # another member of Tag-team
3070             #
3071             # P.315 "Tag-team" matching with /gc
3072             # in Chapter 7: Perl
3073 75131 100 100     91158 # 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          
3074 75131         2999697  
3075 12535 100       15464 if (/\G ( \n ) /oxgc) { # another member (and so on)
3076 12535         21837 my $heredoc = '';
3077             if (scalar(@heredoc_delimiter) >= 1) {
3078 174         233 $slash = 'm//';
3079 174         335  
3080             $heredoc = join '', @heredoc;
3081             @heredoc = ();
3082 174         310  
3083 174         322 # skip here document
3084             for my $heredoc_delimiter (@heredoc_delimiter) {
3085 174         1358 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3086             }
3087 174         318 @heredoc_delimiter = ();
3088              
3089 174         245 $here_script = '';
3090             }
3091             return "\n" . $heredoc;
3092             }
3093 12535         37570  
3094             # ignore space, comment
3095             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3096              
3097             # if (, elsif (, unless (, while (, until (, given (, and when (
3098              
3099             # given, when
3100              
3101             # P.225 The given Statement
3102             # in Chapter 15: Smart Matching and given-when
3103             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3104              
3105             # P.133 The given Statement
3106             # in Chapter 4: Statements and Declarations
3107             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3108 18039         56613  
3109 1401         2080 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3110             $slash = 'm//';
3111             return $1;
3112             }
3113              
3114             # scalar variable ($scalar = ...) =~ tr///;
3115             # scalar variable ($scalar = ...) =~ s///;
3116              
3117             # state
3118              
3119             # P.68 Persistent, Private Variables
3120             # in Chapter 4: Subroutines
3121             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3122              
3123             # P.160 Persistent Lexically Scoped Variables: state
3124             # in Chapter 4: Statements and Declarations
3125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3126              
3127             # (and so on)
3128 1401         4633  
3129             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3130 86 50       189 my $e_string = e_string($1);
    50          
3131 86         2024  
3132 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3133 0         0 $tr_variable = $e_string . e_string($1);
3134 0         0 $bind_operator = $2;
3135             $slash = 'm//';
3136             return '';
3137 0         0 }
3138 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3139 0         0 $sub_variable = $e_string . e_string($1);
3140 0         0 $bind_operator = $2;
3141             $slash = 'm//';
3142             return '';
3143 0         0 }
3144 86         151 else {
3145             $slash = 'div';
3146             return $e_string;
3147             }
3148             }
3149              
3150 86         265 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
3151 4         9 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3152             $slash = 'div';
3153             return q{Elatin10::PREMATCH()};
3154             }
3155              
3156 4         10 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
3157 28         52 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3158             $slash = 'div';
3159             return q{Elatin10::MATCH()};
3160             }
3161              
3162 28         114 # $', ${'} --> $', ${'}
3163 1         1 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3164             $slash = 'div';
3165             return $1;
3166             }
3167              
3168 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
3169 3         7 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3170             $slash = 'div';
3171             return q{Elatin10::POSTMATCH()};
3172             }
3173              
3174             # scalar variable $scalar =~ tr///;
3175             # scalar variable $scalar =~ s///;
3176             # substr() =~ tr///;
3177 3         9 # substr() =~ s///;
3178             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3179 1671 100       3523 my $scalar = e_string($1);
    100          
3180 1671         6304  
3181 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3182 1         3 $tr_variable = $scalar;
3183 1         2 $bind_operator = $1;
3184             $slash = 'm//';
3185             return '';
3186 1         3 }
3187 61         127 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3188 61         113 $sub_variable = $scalar;
3189 61         96 $bind_operator = $1;
3190             $slash = 'm//';
3191             return '';
3192 61         188 }
3193 1609         2245 else {
3194             $slash = 'div';
3195             return $scalar;
3196             }
3197             }
3198              
3199 1609         4446 # end of statement
3200             elsif (/\G ( [,;] ) /oxgc) {
3201             $slash = 'm//';
3202 5011         8095  
3203             # clear tr/// variable
3204             $tr_variable = '';
3205 5011         6551  
3206             # clear s/// variable
3207 5011         6028 $sub_variable = '';
3208              
3209 5011         5683 $bind_operator = '';
3210              
3211             return $1;
3212             }
3213              
3214 5011         17912 # bareword
3215             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3216             return $1;
3217             }
3218              
3219 0         0 # $0 --> $0
3220 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3221             $slash = 'div';
3222             return $1;
3223 2         7 }
3224 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3225             $slash = 'div';
3226             return $1;
3227             }
3228              
3229 0         0 # $$ --> $$
3230 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3231             $slash = 'div';
3232             return $1;
3233             }
3234              
3235             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3236 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3237 4         6 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3238             $slash = 'div';
3239             return e_capture($1);
3240 4         6 }
3241 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3242             $slash = 'div';
3243             return e_capture($1);
3244             }
3245              
3246 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3247 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3248             $slash = 'div';
3249             return e_capture($1.'->'.$2);
3250             }
3251              
3252 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3253 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3254             $slash = 'div';
3255             return e_capture($1.'->'.$2);
3256             }
3257              
3258 0         0 # $$foo
3259 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3260             $slash = 'div';
3261             return e_capture($1);
3262             }
3263              
3264 0         0 # ${ foo }
3265 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3266             $slash = 'div';
3267             return '${' . $1 . '}';
3268             }
3269              
3270 0         0 # ${ ... }
3271 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3272             $slash = 'div';
3273             return e_capture($1);
3274             }
3275              
3276             # variable or function
3277 0         0 # $ @ % & * $ #
3278 42         77 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) {
3279             $slash = 'div';
3280             return $1;
3281             }
3282             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3283 42         133 # $ @ # \ ' " / ? ( ) [ ] < >
3284 62         117 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3285             $slash = 'div';
3286             return $1;
3287             }
3288              
3289 62         201 # while ()
3290             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3291             return $1;
3292             }
3293              
3294             # while () --- glob
3295              
3296             # avoid "Error: Runtime exception" of perl version 5.005_03
3297 0         0  
3298             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3299             return 'while ($_ = Elatin10::glob("' . $1 . '"))';
3300             }
3301              
3302 0         0 # while (glob)
3303             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3304             return 'while ($_ = Elatin10::glob_)';
3305             }
3306              
3307 0         0 # while (glob(WILDCARD))
3308             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3309             return 'while ($_ = Elatin10::glob';
3310             }
3311 0         0  
  248         544  
3312             # doit if, doit unless, doit while, doit until, doit for, doit when
3313             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3314 248         855  
  19         39  
3315 19         66 # subroutines of package Elatin10
  0         0  
3316 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         20  
3317 13         39 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3318 0         0 elsif (/\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         165  
3319 114         309 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
3320 2         7 elsif (/\G \b Latin10::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin10::escape'; }
  0         0  
3321 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
3322 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chop'; }
  0         0  
3323 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3324 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3325 0         0 elsif (/\G \b Latin10::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::index'; }
  2         4  
3326 2         6 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::index'; }
  0         0  
3327 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3328 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3329 0         0 elsif (/\G \b Latin10::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::rindex'; }
  1         3  
3330 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::rindex'; }
  0         0  
3331 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lc'; }
  1         3  
3332 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst'; }
  0         0  
3333 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::uc'; }
  6         9  
3334             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst'; }
3335             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::fc'; }
3336 6         17  
  0         0  
3337 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3338 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3339 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3340 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3341 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3342 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3343             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3344 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  
3345 0         0  
  0         0  
3346 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3347 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3348 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3349 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3350 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3351             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3352             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3353 0         0  
  0         0  
3354 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3355 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3356 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3357             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3358 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3359 2         7  
  2         5  
3360 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         76  
3361 36         120 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3362 2         51 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::chr'; }
  8         17  
3363 8         24 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3364 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3365 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::glob'; }
  0         0  
3366 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lc_'; }
  0         0  
3367 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst_'; }
  0         0  
3368 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::uc_'; }
  0         0  
3369 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst_'; }
  0         0  
3370             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::fc_'; }
3371 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3372 0         0  
  0         0  
3373 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3374 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3375 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chr_'; }
  0         0  
3376 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3377 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3378 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::glob_'; }
  8         19  
3379             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3380             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3381 8         32 # split
3382             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3383 87         182 $slash = 'm//';
3384 87         135  
3385 87         326 my $e = '';
3386             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3387             $e .= $1;
3388             }
3389 85 100       313  
  87 100       5901  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3390             # end of split
3391             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
3392 2         9  
3393             # split scalar value
3394             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin10::split' . $e . e_string($1); }
3395 1         6  
3396 0         0 # split literal space
3397 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {qq$1 $2}; }
3398 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3399 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3400 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3401 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3402 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3403 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {q$1 $2}; }
3404 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3405 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3406 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3407 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3408 10         41 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3409             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin10::split' . $e . qq {' '}; }
3410             elsif (/\G " [ ] " /oxgc) { return 'Elatin10::split' . $e . qq {" "}; }
3411              
3412 0 0       0 # split qq//
  0         0  
3413             elsif (/\G \b (qq) \b /oxgc) {
3414 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3415 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3416 0         0 while (not /\G \z/oxgc) {
3417 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3418 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3419 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3420 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3421 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3422             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3423 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3424             }
3425             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3426             }
3427             }
3428              
3429 0 50       0 # split qr//
  12         416  
3430             elsif (/\G \b (qr) \b /oxgc) {
3431 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3432 12 50       63 else {
  12 50       3409  
    50          
    50          
    50          
    50          
    50          
    50          
3433 0         0 while (not /\G \z/oxgc) {
3434 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3435 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3436 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3437 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3438 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3439 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3440             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3441 12         81 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3442             }
3443             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3444             }
3445             }
3446              
3447 0 0       0 # split q//
  0         0  
3448             elsif (/\G \b (q) \b /oxgc) {
3449 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3450 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3451 0         0 while (not /\G \z/oxgc) {
3452 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3453 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3454 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3455 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3456 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3457             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3458 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3459             }
3460             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3461             }
3462             }
3463              
3464 0 50       0 # split m//
  18         466  
3465             elsif (/\G \b (m) \b /oxgc) {
3466 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3467 18 50       92 else {
  18 50       4195  
    50          
    50          
    50          
    50          
    50          
    50          
3468 0         0 while (not /\G \z/oxgc) {
3469 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3470 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3471 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3472 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3473 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3474 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3475             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3476 18         106 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3477             }
3478             die __FILE__, ": Search pattern not terminated\n";
3479             }
3480             }
3481              
3482 0         0 # split ''
3483 0         0 elsif (/\G (\') /oxgc) {
3484 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3485 0         0 while (not /\G \z/oxgc) {
3486 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3487 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3488             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3489 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3490             }
3491             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3492             }
3493              
3494 0         0 # split ""
3495 0         0 elsif (/\G (\") /oxgc) {
3496 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3497 0         0 while (not /\G \z/oxgc) {
3498 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3499 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3500             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3501 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3502             }
3503             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3504             }
3505              
3506 0         0 # split //
3507 44         118 elsif (/\G (\/) /oxgc) {
3508 44 50       160 my $regexp = '';
  381 50       1629  
    100          
    50          
3509 0         0 while (not /\G \z/oxgc) {
3510 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3511 44         188 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3512             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3513 337         701 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3514             }
3515             die __FILE__, ": Search pattern not terminated\n";
3516             }
3517             }
3518              
3519             # tr/// or y///
3520              
3521             # about [cdsrbB]* (/B modifier)
3522             #
3523             # P.559 appendix C
3524             # of ISBN 4-89052-384-7 Programming perl
3525             # (Japanese title is: Perl puroguramingu)
3526 0         0  
3527             elsif (/\G \b ( tr | y ) \b /oxgc) {
3528             my $ope = $1;
3529 3 50       7  
3530 3         40 # $1 $2 $3 $4 $5 $6
3531 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3532             my @tr = ($tr_variable,$2);
3533             return e_tr(@tr,'',$4,$6);
3534 0         0 }
3535 3         5 else {
3536 3 50       8 my $e = '';
  3 50       227  
    50          
    50          
    50          
    50          
3537             while (not /\G \z/oxgc) {
3538 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3539 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3540 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3541 0         0 while (not /\G \z/oxgc) {
3542 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3543 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3544 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3545 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3546             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3547 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3548             }
3549             die __FILE__, ": Transliteration replacement not terminated\n";
3550 0         0 }
3551 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3552 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3553 0         0 while (not /\G \z/oxgc) {
3554 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3555 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3556 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3557 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3558             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3559 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3560             }
3561             die __FILE__, ": Transliteration replacement not terminated\n";
3562 0         0 }
3563 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3564 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3565 0         0 while (not /\G \z/oxgc) {
3566 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3567 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3568 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3569 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3570             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3571 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3572             }
3573             die __FILE__, ": Transliteration replacement not terminated\n";
3574 0         0 }
3575 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3576 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3577 0         0 while (not /\G \z/oxgc) {
3578 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3579 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3580 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3581 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3582             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3583 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3584             }
3585             die __FILE__, ": Transliteration replacement not terminated\n";
3586             }
3587 0         0 # $1 $2 $3 $4 $5 $6
3588 3         11 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3589             my @tr = ($tr_variable,$2);
3590             return e_tr(@tr,'',$4,$6);
3591 3         8 }
3592             }
3593             die __FILE__, ": Transliteration pattern not terminated\n";
3594             }
3595             }
3596              
3597 0         0 # qq//
3598             elsif (/\G \b (qq) \b /oxgc) {
3599             my $ope = $1;
3600 2180 50       4895  
3601 2180         3976 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3602 0         0 if (/\G (\#) /oxgc) { # qq# #
3603 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3604 0         0 while (not /\G \z/oxgc) {
3605 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3606 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3607             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3608 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3609             }
3610             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3611             }
3612 0         0  
3613 2180         3047 else {
3614 2180 50       6008 my $e = '';
  2180 50       8262  
    100          
    50          
    50          
    0          
3615             while (not /\G \z/oxgc) {
3616             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3617              
3618 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3619 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3620 0         0 my $qq_string = '';
3621 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3622 0         0 while (not /\G \z/oxgc) {
3623 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3624             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3625 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3626 0         0 elsif (/\G (\)) /oxgc) {
3627             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3628 0         0 else { $qq_string .= $1; }
3629             }
3630 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3631             }
3632             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3633             }
3634              
3635 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3636 2150         3035 elsif (/\G (\{) /oxgc) { # qq { }
3637 2150         3010 my $qq_string = '';
3638 2150 100       4463 local $nest = 1;
  84019 50       264931  
    100          
    100          
    50          
3639 722         1432 while (not /\G \z/oxgc) {
3640 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1614  
3641             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3642 1153 100       2035 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         4930  
3643 2150         4201 elsif (/\G (\}) /oxgc) {
3644             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3645 1153         2478 else { $qq_string .= $1; }
3646             }
3647 78841         176286 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3648             }
3649             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3650             }
3651              
3652 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3653 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3654 0         0 my $qq_string = '';
3655 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3656 0         0 while (not /\G \z/oxgc) {
3657 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3658             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3659 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3660 0         0 elsif (/\G (\]) /oxgc) {
3661             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3662 0         0 else { $qq_string .= $1; }
3663             }
3664 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3665             }
3666             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3667             }
3668              
3669 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3670 30         49 elsif (/\G (\<) /oxgc) { # qq < >
3671 30         52 my $qq_string = '';
3672 30 100       91 local $nest = 1;
  1166 50       4069  
    50          
    100          
    50          
3673 22         55 while (not /\G \z/oxgc) {
3674 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3675             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3676 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         79  
3677 30         118 elsif (/\G (\>) /oxgc) {
3678             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3679 0         0 else { $qq_string .= $1; }
3680             }
3681 1114         2300 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3682             }
3683             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3684             }
3685              
3686 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3687 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3688 0         0 my $delimiter = $1;
3689 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3690 0         0 while (not /\G \z/oxgc) {
3691 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3692 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3693             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3694 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3695             }
3696             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3697 0         0 }
3698             }
3699             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3700             }
3701             }
3702              
3703 0         0 # qr//
3704 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3705 0         0 my $ope = $1;
3706             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3707             return e_qr($ope,$1,$3,$2,$4);
3708 0         0 }
3709 0         0 else {
3710 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3711 0         0 while (not /\G \z/oxgc) {
3712 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3713 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3714 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3715 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3716 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3717 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3718             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3719 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3720             }
3721             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3722             }
3723             }
3724              
3725 0         0 # qw//
3726 16 50       49 elsif (/\G \b (qw) \b /oxgc) {
3727 16         75 my $ope = $1;
3728             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3729             return e_qw($ope,$1,$3,$2);
3730 0         0 }
3731 16         36 else {
3732 16 50       64 my $e = '';
  16 50       96  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3733             while (not /\G \z/oxgc) {
3734 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3735 16         83  
3736             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3737 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3738 0         0  
3739             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3740 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3741 0         0  
3742             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3743 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3744 0         0  
3745             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3746 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3747 0         0  
3748             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3749 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3750             }
3751             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3752             }
3753             }
3754              
3755 0         0 # qx//
3756 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3757 0         0 my $ope = $1;
3758             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3759             return e_qq($ope,$1,$3,$2);
3760 0         0 }
3761 0         0 else {
3762 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3763 0         0 while (not /\G \z/oxgc) {
3764 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3765 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3766 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3767 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3768 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3769             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3770 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3771             }
3772             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3773             }
3774             }
3775              
3776 0         0 # q//
3777             elsif (/\G \b (q) \b /oxgc) {
3778             my $ope = $1;
3779              
3780             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3781              
3782             # avoid "Error: Runtime exception" of perl version 5.005_03
3783 410 50       1099 # (and so on)
3784 410         978  
3785 0         0 if (/\G (\#) /oxgc) { # q# #
3786 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3787 0         0 while (not /\G \z/oxgc) {
3788 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3789 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3790             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3791 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3792             }
3793             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3794             }
3795 0         0  
3796 410         698 else {
3797 410 50       1184 my $e = '';
  410 50       1999  
    100          
    50          
    100          
    50          
3798             while (not /\G \z/oxgc) {
3799             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3800              
3801 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3802 0         0 elsif (/\G (\() /oxgc) { # q ( )
3803 0         0 my $q_string = '';
3804 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3805 0         0 while (not /\G \z/oxgc) {
3806 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3807 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3808             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3809 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3810 0         0 elsif (/\G (\)) /oxgc) {
3811             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3812 0         0 else { $q_string .= $1; }
3813             }
3814 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3815             }
3816             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3817             }
3818              
3819 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3820 404         707 elsif (/\G (\{) /oxgc) { # q { }
3821 404         695 my $q_string = '';
3822 404 50       1044 local $nest = 1;
  6783 50       25864  
    50          
    100          
    100          
    50          
3823 0         0 while (not /\G \z/oxgc) {
3824 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3825 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         162  
3826             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3827 107 100       186 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1132  
3828 404         1072 elsif (/\G (\}) /oxgc) {
3829             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3830 107         209 else { $q_string .= $1; }
3831             }
3832 6165         12353 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3833             }
3834             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3835             }
3836              
3837 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3838 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3839 0         0 my $q_string = '';
3840 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3841 0         0 while (not /\G \z/oxgc) {
3842 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3843 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3844             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3845 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3846 0         0 elsif (/\G (\]) /oxgc) {
3847             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3848 0         0 else { $q_string .= $1; }
3849             }
3850 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3851             }
3852             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3853             }
3854              
3855 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3856 5         11 elsif (/\G (\<) /oxgc) { # q < >
3857 5         11 my $q_string = '';
3858 5 50       19 local $nest = 1;
  88 50       366  
    50          
    50          
    100          
    50          
3859 0         0 while (not /\G \z/oxgc) {
3860 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3861 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3862             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3863 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         13  
3864 5         14 elsif (/\G (\>) /oxgc) {
3865             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3866 0         0 else { $q_string .= $1; }
3867             }
3868 83         155 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3869             }
3870             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3871             }
3872              
3873 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3874 1         2 elsif (/\G (\S) /oxgc) { # q * *
3875 1         2 my $delimiter = $1;
3876 1 50       4 my $q_string = '';
  14 50       77  
    100          
    50          
3877 0         0 while (not /\G \z/oxgc) {
3878 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3879 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3880             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3881 13         26 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3882             }
3883             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3884 0         0 }
3885             }
3886             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3887             }
3888             }
3889              
3890 0         0 # m//
3891 209 50       5299 elsif (/\G \b (m) \b /oxgc) {
3892 209         1464 my $ope = $1;
3893             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3894             return e_qr($ope,$1,$3,$2,$4);
3895 0         0 }
3896 209         337 else {
3897 209 50       634 my $e = '';
  209 50       11386  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3898 0         0 while (not /\G \z/oxgc) {
3899 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3900 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3901 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3902 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3903 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3904 10         33 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3905 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3906             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3907 199         666 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3908             }
3909             die __FILE__, ": Search pattern not terminated\n";
3910             }
3911             }
3912              
3913             # s///
3914              
3915             # about [cegimosxpradlunbB]* (/cg modifier)
3916             #
3917             # P.67 Pattern-Matching Operators
3918             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3919 0         0  
3920             elsif (/\G \b (s) \b /oxgc) {
3921             my $ope = $1;
3922 97 100       261  
3923 97         1677 # $1 $2 $3 $4 $5 $6
3924             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3925             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3926 1         6 }
3927 96         195 else {
3928 96 50       306 my $e = '';
  96 50       11692  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3929             while (not /\G \z/oxgc) {
3930 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3931 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3932 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3933             while (not /\G \z/oxgc) {
3934 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3935 0         0 # $1 $2 $3 $4
3936 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945             }
3946             die __FILE__, ": Substitution replacement not terminated\n";
3947 0         0 }
3948 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3949 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3950             while (not /\G \z/oxgc) {
3951 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3952 0         0 # $1 $2 $3 $4
3953 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962             }
3963             die __FILE__, ": Substitution replacement not terminated\n";
3964 0         0 }
3965 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3966 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3967             while (not /\G \z/oxgc) {
3968 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3969 0         0 # $1 $2 $3 $4
3970 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977             }
3978             die __FILE__, ": Substitution replacement not terminated\n";
3979 0         0 }
3980 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3981 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3982             while (not /\G \z/oxgc) {
3983 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3984 0         0 # $1 $2 $3 $4
3985 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3986 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3987 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3988 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3989 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3990 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3991 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3992             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3993 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3994             }
3995             die __FILE__, ": Substitution replacement not terminated\n";
3996             }
3997 0         0 # $1 $2 $3 $4 $5 $6
3998             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3999             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4000             }
4001 21         86 # $1 $2 $3 $4 $5 $6
4002             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4003             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4004             }
4005 0         0 # $1 $2 $3 $4 $5 $6
4006             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4007             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4008             }
4009 0         0 # $1 $2 $3 $4 $5 $6
4010             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4011             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4012 75         336 }
4013             }
4014             die __FILE__, ": Substitution pattern not terminated\n";
4015             }
4016             }
4017 0         0  
4018 0         0 # require ignore module
4019 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4020             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4021             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4022 0         0  
4023 37         292 # use strict; --> use strict; no strict qw(refs);
4024 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4025             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4026             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4027              
4028 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4029 2         23 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4030             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4031             return "use $1; no strict qw(refs);";
4032 0         0 }
4033             else {
4034             return "use $1;";
4035             }
4036 2 0 0     11 }
      0        
4037 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4038             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4039             return "use $1; no strict qw(refs);";
4040 0         0 }
4041             else {
4042             return "use $1;";
4043             }
4044             }
4045 0         0  
4046 2         17 # ignore use module
4047 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4048             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4049             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4050 0         0  
4051 0         0 # ignore no module
4052 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4053             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4054             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4055 0         0  
4056             # use else
4057             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4058 0         0  
4059             # use else
4060             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4061              
4062 2         9 # ''
4063 848         1803 elsif (/\G (?
4064 848 100       2218 my $q_string = '';
  8267 100       25898  
    100          
    50          
4065 4         10 while (not /\G \z/oxgc) {
4066 48         101 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4067 848         1857 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4068             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4069 7367         14968 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4070             }
4071             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4072             }
4073              
4074 0         0 # ""
4075 1830         3512 elsif (/\G (\") /oxgc) {
4076 1830 100       4672 my $qq_string = '';
  35512 100       98654  
    100          
    50          
4077 67         164 while (not /\G \z/oxgc) {
4078 12         25 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4079 1830         5092 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4080             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4081 33603         73165 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4082             }
4083             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4084             }
4085              
4086 0         0 # ``
4087 1         3 elsif (/\G (\`) /oxgc) {
4088 1 50       4 my $qx_string = '';
  19 50       69  
    100          
    50          
4089 0         0 while (not /\G \z/oxgc) {
4090 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4091 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4092             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4093 18         35 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4094             }
4095             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4096             }
4097              
4098 0         0 # // --- not divide operator (num / num), not defined-or
4099 453         1621 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4100 453 50       1309 my $regexp = '';
  4496 50       31953  
    100          
    50          
4101 0         0 while (not /\G \z/oxgc) {
4102 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4103 453         1489 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4104             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4105 4043         8484 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4106             }
4107             die __FILE__, ": Search pattern not terminated\n";
4108             }
4109              
4110 0         0 # ?? --- not conditional operator (condition ? then : else)
4111 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4112 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4113 0         0 while (not /\G \z/oxgc) {
4114 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4115 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4116             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4117 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4118             }
4119             die __FILE__, ": Search pattern not terminated\n";
4120             }
4121 0         0  
  0         0  
4122             # <<>> (a safer ARGV)
4123             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4124 0         0  
  0         0  
4125             # << (bit shift) --- not here document
4126             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4127              
4128 0         0 # <<~'HEREDOC'
4129 6         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4130 6         10 $slash = 'm//';
4131             my $here_quote = $1;
4132             my $delimiter = $2;
4133 6 50       10  
4134 6         14 # get here document
4135 6         22 if ($here_script eq '') {
4136             $here_script = CORE::substr $_, pos $_;
4137 6 50       31 $here_script =~ s/.*?\n//oxm;
4138 6         70 }
4139 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4140 6         9 my $heredoc = $1;
4141 6         47 my $indent = $2;
4142 6         21 $heredoc =~ s{^$indent}{}msg; # no /ox
4143             push @heredoc, $heredoc . qq{\n$delimiter\n};
4144             push @heredoc_delimiter, qq{\\s*$delimiter};
4145 6         13 }
4146             else {
4147 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4148             }
4149             return qq{<<'$delimiter'};
4150             }
4151              
4152             # <<~\HEREDOC
4153              
4154             # P.66 2.6.6. "Here" Documents
4155             # in Chapter 2: Bits and Pieces
4156             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4157              
4158             # P.73 "Here" Documents
4159             # in Chapter 2: Bits and Pieces
4160             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4161 6         24  
4162 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4163 3         6 $slash = 'm//';
4164             my $here_quote = $1;
4165             my $delimiter = $2;
4166 3 50       7  
4167 3         8 # get here document
4168 3         21 if ($here_script eq '') {
4169             $here_script = CORE::substr $_, pos $_;
4170 3 50       20 $here_script =~ s/.*?\n//oxm;
4171 3         41 }
4172 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4173 3         7 my $heredoc = $1;
4174 3         39 my $indent = $2;
4175 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4176             push @heredoc, $heredoc . qq{\n$delimiter\n};
4177             push @heredoc_delimiter, qq{\\s*$delimiter};
4178 3         18 }
4179             else {
4180 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4181             }
4182             return qq{<<\\$delimiter};
4183             }
4184              
4185 3         16 # <<~"HEREDOC"
4186 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4187 6         14 $slash = 'm//';
4188             my $here_quote = $1;
4189             my $delimiter = $2;
4190 6 50       11  
4191 6         13 # get here document
4192 6         30 if ($here_script eq '') {
4193             $here_script = CORE::substr $_, pos $_;
4194 6 50       31 $here_script =~ s/.*?\n//oxm;
4195 6         55 }
4196 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4197 6         17 my $heredoc = $1;
4198 6         48 my $indent = $2;
4199 6         16 $heredoc =~ s{^$indent}{}msg; # no /ox
4200             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4201             push @heredoc_delimiter, qq{\\s*$delimiter};
4202 6         16 }
4203             else {
4204 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4205             }
4206             return qq{<<"$delimiter"};
4207             }
4208              
4209 6         27 # <<~HEREDOC
4210 3         8 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4211 3         7 $slash = 'm//';
4212             my $here_quote = $1;
4213             my $delimiter = $2;
4214 3 50       7  
4215 3         7 # get here document
4216 3         27 if ($here_script eq '') {
4217             $here_script = CORE::substr $_, pos $_;
4218 3 50       27 $here_script =~ s/.*?\n//oxm;
4219 3         43 }
4220 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4221 3         7 my $heredoc = $1;
4222 3         49 my $indent = $2;
4223 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4224             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4225             push @heredoc_delimiter, qq{\\s*$delimiter};
4226 3         8 }
4227             else {
4228 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4229             }
4230             return qq{<<$delimiter};
4231             }
4232              
4233 3         14 # <<~`HEREDOC`
4234 6         12 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4235 6         57 $slash = 'm//';
4236             my $here_quote = $1;
4237             my $delimiter = $2;
4238 6 50       17  
4239 6         18 # get here document
4240 6         41 if ($here_script eq '') {
4241             $here_script = CORE::substr $_, pos $_;
4242 6 50       40 $here_script =~ s/.*?\n//oxm;
4243 6         70 }
4244 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4245 6         39 my $heredoc = $1;
4246 6         59 my $indent = $2;
4247 6         27 $heredoc =~ s{^$indent}{}msg; # no /ox
4248             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4249             push @heredoc_delimiter, qq{\\s*$delimiter};
4250 6         20 }
4251             else {
4252 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4253             }
4254             return qq{<<`$delimiter`};
4255             }
4256              
4257 6         28 # <<'HEREDOC'
4258 72         139 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4259 72         292 $slash = 'm//';
4260             my $here_quote = $1;
4261             my $delimiter = $2;
4262 72 50       112  
4263 72         155 # get here document
4264 72         354 if ($here_script eq '') {
4265             $here_script = CORE::substr $_, pos $_;
4266 72 50       435 $here_script =~ s/.*?\n//oxm;
4267 72         539 }
4268 72         242 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4269             push @heredoc, $1 . qq{\n$delimiter\n};
4270             push @heredoc_delimiter, $delimiter;
4271 72         105 }
4272             else {
4273 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4274             }
4275             return $here_quote;
4276             }
4277              
4278             # <<\HEREDOC
4279              
4280             # P.66 2.6.6. "Here" Documents
4281             # in Chapter 2: Bits and Pieces
4282             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4283              
4284             # P.73 "Here" Documents
4285             # in Chapter 2: Bits and Pieces
4286             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4287 72         272  
4288 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4289 0         0 $slash = 'm//';
4290             my $here_quote = $1;
4291             my $delimiter = $2;
4292 0 0       0  
4293 0         0 # get here document
4294 0         0 if ($here_script eq '') {
4295             $here_script = CORE::substr $_, pos $_;
4296 0 0       0 $here_script =~ s/.*?\n//oxm;
4297 0         0 }
4298 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4299             push @heredoc, $1 . qq{\n$delimiter\n};
4300             push @heredoc_delimiter, $delimiter;
4301 0         0 }
4302             else {
4303 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4304             }
4305             return $here_quote;
4306             }
4307              
4308 0         0 # <<"HEREDOC"
4309 36         86 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4310 36         88 $slash = 'm//';
4311             my $here_quote = $1;
4312             my $delimiter = $2;
4313 36 50       67  
4314 36         97 # get here document
4315 36         239 if ($here_script eq '') {
4316             $here_script = CORE::substr $_, pos $_;
4317 36 50       196 $here_script =~ s/.*?\n//oxm;
4318 36         626 }
4319 36         111 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4320             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4321             push @heredoc_delimiter, $delimiter;
4322 36         84 }
4323             else {
4324 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4325             }
4326             return $here_quote;
4327             }
4328              
4329 36         230 # <
4330 42         415 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4331 42         96 $slash = 'm//';
4332             my $here_quote = $1;
4333             my $delimiter = $2;
4334 42 50       78  
4335 42         107 # get here document
4336 42         336 if ($here_script eq '') {
4337             $here_script = CORE::substr $_, pos $_;
4338 42 50       323 $here_script =~ s/.*?\n//oxm;
4339 42         1020 }
4340 42         148 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4341             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4342             push @heredoc_delimiter, $delimiter;
4343 42         94 }
4344             else {
4345 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4346             }
4347             return $here_quote;
4348             }
4349              
4350 42         176 # <<`HEREDOC`
4351 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4352 0         0 $slash = 'm//';
4353             my $here_quote = $1;
4354             my $delimiter = $2;
4355 0 0       0  
4356 0         0 # get here document
4357 0         0 if ($here_script eq '') {
4358             $here_script = CORE::substr $_, pos $_;
4359 0 0       0 $here_script =~ s/.*?\n//oxm;
4360 0         0 }
4361 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4362             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4363             push @heredoc_delimiter, $delimiter;
4364 0         0 }
4365             else {
4366 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4367             }
4368             return $here_quote;
4369             }
4370              
4371 0         0 # <<= <=> <= < operator
4372             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4373             return $1;
4374             }
4375              
4376 12         66 #
4377             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4378             return $1;
4379             }
4380              
4381             # --- glob
4382              
4383             # avoid "Error: Runtime exception" of perl version 5.005_03
4384 0         0  
4385             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4386             return 'Elatin10::glob("' . $1 . '")';
4387             }
4388 0         0  
4389             # __DATA__
4390             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4391 0         0  
4392             # __END__
4393             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4394              
4395             # \cD Control-D
4396              
4397             # P.68 2.6.8. Other Literal Tokens
4398             # in Chapter 2: Bits and Pieces
4399             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4400              
4401             # P.76 Other Literal Tokens
4402             # in Chapter 2: Bits and Pieces
4403 204         1787 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4404              
4405             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4406 0         0  
4407             # \cZ Control-Z
4408             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4409              
4410             # any operator before div
4411             elsif (/\G (
4412             -- | \+\+ |
4413 0         0 [\)\}\]]
  5081         10984  
4414              
4415             ) /oxgc) { $slash = 'div'; return $1; }
4416              
4417             # yada-yada or triple-dot operator
4418             elsif (/\G (
4419 5081         23741 \.\.\.
  7         12  
4420              
4421             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4422              
4423             # any operator before m//
4424              
4425             # //, //= (defined-or)
4426              
4427             # P.164 Logical Operators
4428             # in Chapter 10: More Control Structures
4429             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4430              
4431             # P.119 C-Style Logical (Short-Circuit) Operators
4432             # in Chapter 3: Unary and Binary Operators
4433             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4434              
4435             # (and so on)
4436              
4437             # ~~
4438              
4439             # P.221 The Smart Match Operator
4440             # in Chapter 15: Smart Matching and given-when
4441             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4442              
4443             # P.112 Smartmatch Operator
4444             # in Chapter 3: Unary and Binary Operators
4445             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4446              
4447             # (and so on)
4448              
4449             elsif (/\G ((?>
4450              
4451             !~~ | !~ | != | ! |
4452             %= | % |
4453             &&= | && | &= | &\.= | &\. | & |
4454             -= | -> | - |
4455             :(?>\s*)= |
4456             : |
4457             <<>> |
4458             <<= | <=> | <= | < |
4459             == | => | =~ | = |
4460             >>= | >> | >= | > |
4461             \*\*= | \*\* | \*= | \* |
4462             \+= | \+ |
4463             \.\. | \.= | \. |
4464             \/\/= | \/\/ |
4465             \/= | \/ |
4466             \? |
4467             \\ |
4468             \^= | \^\.= | \^\. | \^ |
4469             \b x= |
4470             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4471             ~~ | ~\. | ~ |
4472             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4473             \b(?: print )\b |
4474              
4475 7         25 [,;\(\{\[]
  8859         20094  
4476              
4477             )) /oxgc) { $slash = 'm//'; return $1; }
4478 8859         40401  
  15261         29066  
4479             # other any character
4480             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4481              
4482 15261         69756 # system error
4483             else {
4484             die __FILE__, ": Oops, this shouldn't happen!\n";
4485             }
4486             }
4487              
4488 0     1786 0 0 # escape Latin-10 string
4489 1786         4300 sub e_string {
4490             my($string) = @_;
4491 1786         2399 my $e_string = '';
4492              
4493             local $slash = 'm//';
4494              
4495             # P.1024 Appendix W.10 Multibyte Processing
4496             # of ISBN 1-56592-224-7 CJKV Information Processing
4497 1786         2504 # (and so on)
4498              
4499             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4500 1786 100 66     13099  
4501 1786 50       7428 # without { ... }
4502 1769         4159 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4503             if ($string !~ /<
4504             return $string;
4505             }
4506             }
4507 1769         4405  
4508 17 50       51 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          
4509             while ($string !~ /\G \z/oxgc) {
4510             if (0) {
4511             }
4512 190         11334  
4513 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin10::PREMATCH()]}
4514 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4515             $e_string .= q{Elatin10::PREMATCH()};
4516             $slash = 'div';
4517             }
4518              
4519 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin10::MATCH()]}
4520 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4521             $e_string .= q{Elatin10::MATCH()};
4522             $slash = 'div';
4523             }
4524              
4525 0         0 # $', ${'} --> $', ${'}
4526 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4527             $e_string .= $1;
4528             $slash = 'div';
4529             }
4530              
4531 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin10::POSTMATCH()]}
4532 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4533             $e_string .= q{Elatin10::POSTMATCH()};
4534             $slash = 'div';
4535             }
4536              
4537 0         0 # bareword
4538 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4539             $e_string .= $1;
4540             $slash = 'div';
4541             }
4542              
4543 0         0 # $0 --> $0
4544 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4545             $e_string .= $1;
4546             $slash = 'div';
4547 0         0 }
4548 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4549             $e_string .= $1;
4550             $slash = 'div';
4551             }
4552              
4553 0         0 # $$ --> $$
4554 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4555             $e_string .= $1;
4556             $slash = 'div';
4557             }
4558              
4559             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4560 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4561 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4562             $e_string .= e_capture($1);
4563             $slash = 'div';
4564 0         0 }
4565 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4566             $e_string .= e_capture($1);
4567             $slash = 'div';
4568             }
4569              
4570 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4571 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4572             $e_string .= e_capture($1.'->'.$2);
4573             $slash = 'div';
4574             }
4575              
4576 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4577 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4578             $e_string .= e_capture($1.'->'.$2);
4579             $slash = 'div';
4580             }
4581              
4582 0         0 # $$foo
4583 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4584             $e_string .= e_capture($1);
4585             $slash = 'div';
4586             }
4587              
4588 0         0 # ${ foo }
4589 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4590             $e_string .= '${' . $1 . '}';
4591             $slash = 'div';
4592             }
4593              
4594 0         0 # ${ ... }
4595 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4596             $e_string .= e_capture($1);
4597             $slash = 'div';
4598             }
4599              
4600             # variable or function
4601 3         15 # $ @ % & * $ #
4602 7         38 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) {
4603             $e_string .= $1;
4604             $slash = 'div';
4605             }
4606             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4607 7         23 # $ @ # \ ' " / ? ( ) [ ] < >
4608 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4609             $e_string .= $1;
4610             $slash = 'div';
4611             }
4612 0         0  
  0         0  
4613 0         0 # subroutines of package Elatin10
  0         0  
4614 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4615 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4616 0         0 elsif ($string =~ /\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4617 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4618 0         0 elsif ($string =~ /\G \b Latin10::eval \b /oxgc) { $e_string .= 'eval Latin10::escape'; $slash = 'm//'; }
  0         0  
4619 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4620 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin10::chop'; $slash = 'm//'; }
  0         0  
4621 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4622 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4623 0         0 elsif ($string =~ /\G \b Latin10::index \b /oxgc) { $e_string .= 'Latin10::index'; $slash = 'm//'; }
  0         0  
4624 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin10::index'; $slash = 'm//'; }
  0         0  
4625 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4626 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4627 0         0 elsif ($string =~ /\G \b Latin10::rindex \b /oxgc) { $e_string .= 'Latin10::rindex'; $slash = 'm//'; }
  0         0  
4628 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin10::rindex'; $slash = 'm//'; }
  0         0  
4629 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lc'; $slash = 'm//'; }
  0         0  
4630 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lcfirst'; $slash = 'm//'; }
  0         0  
4631 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::uc'; $slash = 'm//'; }
  0         0  
4632             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::ucfirst'; $slash = 'm//'; }
4633             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::fc'; $slash = 'm//'; }
4634 0         0  
  0         0  
4635 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4636 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4637 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  
4638 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  
4639 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  
4640 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  
4641             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4642 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  
4643 0         0  
  0         0  
4644 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4645 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  
4646 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  
4647 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  
4648 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  
4649             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4650             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4651 0         0  
  0         0  
4652 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4653 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4654 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4655             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4656 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4657 0         0  
  0         0  
4658 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4659 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4660 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::chr'; $slash = 'm//'; }
  0         0  
4661 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4662 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4663 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::glob'; $slash = 'm//'; }
  0         0  
4664 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin10::lc_'; $slash = 'm//'; }
  0         0  
4665 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin10::lcfirst_'; $slash = 'm//'; }
  0         0  
4666 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin10::uc_'; $slash = 'm//'; }
  0         0  
4667 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin10::ucfirst_'; $slash = 'm//'; }
  0         0  
4668             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin10::fc_'; $slash = 'm//'; }
4669 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4670 0         0  
  0         0  
4671 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin10::chr_'; $slash = 'm//'; }
  0         0  
4674 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin10::glob_'; $slash = 'm//'; }
  0         0  
4677             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4678             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4679 0         0 # split
4680             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4681 0         0 $slash = 'm//';
4682 0         0  
4683 0         0 my $e = '';
4684             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4685             $e .= $1;
4686             }
4687 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4688             # end of split
4689             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
4690 0         0  
  0         0  
4691             # split scalar value
4692             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin10::split' . $e . e_string($1); next E_STRING_LOOP; }
4693 0         0  
  0         0  
4694 0         0 # split literal space
  0         0  
4695 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4696 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4697 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4698 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4699 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4700 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  
4701 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4702 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4703 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4704 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4705 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4706 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  
4707             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {' '}; next E_STRING_LOOP; }
4708             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {" "}; next E_STRING_LOOP; }
4709              
4710 0 0       0 # split qq//
  0         0  
  0         0  
4711             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4712 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4713 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4714 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4715 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4716 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  
4717 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  
4718 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  
4719 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  
4720             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4721 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 * *
4722             }
4723             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4724             }
4725             }
4726              
4727 0 0       0 # split qr//
  0         0  
  0         0  
4728             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4729 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4730 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4731 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4732 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4733 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  
4734 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  
4735 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  
4736 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  
4737 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  
4738             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4739 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 * *
4740             }
4741             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4742             }
4743             }
4744              
4745 0 0       0 # split q//
  0         0  
  0         0  
4746             elsif ($string =~ /\G \b (q) \b /oxgc) {
4747 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4748 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4749 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4750 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4751 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  
4752 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  
4753 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  
4754 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  
4755             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4756 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 * *
4757             }
4758             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4759             }
4760             }
4761              
4762 0 0       0 # split m//
  0         0  
  0         0  
4763             elsif ($string =~ /\G \b (m) \b /oxgc) {
4764 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 # #
4765 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4766 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4767 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4768 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  
4769 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  
4770 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  
4771 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  
4772 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  
4773             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4774 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 * *
4775             }
4776             die __FILE__, ": Search pattern not terminated\n";
4777             }
4778             }
4779              
4780 0         0 # split ''
4781 0         0 elsif ($string =~ /\G (\') /oxgc) {
4782 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4783 0         0 while ($string !~ /\G \z/oxgc) {
4784 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4785 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4786             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4787 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4788             }
4789             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4790             }
4791              
4792 0         0 # split ""
4793 0         0 elsif ($string =~ /\G (\") /oxgc) {
4794 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4795 0         0 while ($string !~ /\G \z/oxgc) {
4796 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4797 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4798             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4799 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4800             }
4801             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4802             }
4803              
4804 0         0 # split //
4805 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4806 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4807 0         0 while ($string !~ /\G \z/oxgc) {
4808 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4809 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4810             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4811 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4812             }
4813             die __FILE__, ": Search pattern not terminated\n";
4814             }
4815             }
4816              
4817 0         0 # qq//
4818 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4819 0         0 my $ope = $1;
4820             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4821             $e_string .= e_qq($ope,$1,$3,$2);
4822 0         0 }
4823 0         0 else {
4824 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4825 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4826 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4827 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4828 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4829 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4830             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4831 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4832             }
4833             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4834             }
4835             }
4836              
4837 0         0 # qx//
4838 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4839 0         0 my $ope = $1;
4840             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4841             $e_string .= e_qq($ope,$1,$3,$2);
4842 0         0 }
4843 0         0 else {
4844 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4845 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4846 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4847 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4848 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4849 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4850 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4851             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4852 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4853             }
4854             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4855             }
4856             }
4857              
4858 0         0 # q//
4859 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4860 0         0 my $ope = $1;
4861             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4862             $e_string .= e_q($ope,$1,$3,$2);
4863 0         0 }
4864 0         0 else {
4865 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4866 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4867 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4868 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4869 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4870 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4871             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4872 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 * *
4873             }
4874             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4875             }
4876             }
4877 0         0  
4878             # ''
4879             elsif ($string =~ /\G (?
4880 0         0  
4881             # ""
4882             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4883 0         0  
4884             # ``
4885             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4886 0         0  
4887             # <<>> (a safer ARGV)
4888             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4889 0         0  
4890             # <<= <=> <= < operator
4891             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4892 0         0  
4893             #
4894             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4895              
4896 0         0 # --- glob
4897             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4898             $e_string .= 'Elatin10::glob("' . $1 . '")';
4899             }
4900              
4901 0         0 # << (bit shift) --- not here document
4902 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4903             $slash = 'm//';
4904             $e_string .= $1;
4905             }
4906              
4907 0         0 # <<~'HEREDOC'
4908 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4909 0         0 $slash = 'm//';
4910             my $here_quote = $1;
4911             my $delimiter = $2;
4912 0 0       0  
4913 0         0 # get here document
4914 0         0 if ($here_script eq '') {
4915             $here_script = CORE::substr $_, pos $_;
4916 0 0       0 $here_script =~ s/.*?\n//oxm;
4917 0         0 }
4918 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4919 0         0 my $heredoc = $1;
4920 0         0 my $indent = $2;
4921 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4922             push @heredoc, $heredoc . qq{\n$delimiter\n};
4923             push @heredoc_delimiter, qq{\\s*$delimiter};
4924 0         0 }
4925             else {
4926 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4927             }
4928             $e_string .= qq{<<'$delimiter'};
4929             }
4930              
4931 0         0 # <<~\HEREDOC
4932 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4933 0         0 $slash = 'm//';
4934             my $here_quote = $1;
4935             my $delimiter = $2;
4936 0 0       0  
4937 0         0 # get here document
4938 0         0 if ($here_script eq '') {
4939             $here_script = CORE::substr $_, pos $_;
4940 0 0       0 $here_script =~ s/.*?\n//oxm;
4941 0         0 }
4942 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4943 0         0 my $heredoc = $1;
4944 0         0 my $indent = $2;
4945 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4946             push @heredoc, $heredoc . qq{\n$delimiter\n};
4947             push @heredoc_delimiter, qq{\\s*$delimiter};
4948 0         0 }
4949             else {
4950 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4951             }
4952             $e_string .= qq{<<\\$delimiter};
4953             }
4954              
4955 0         0 # <<~"HEREDOC"
4956 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4957 0         0 $slash = 'm//';
4958             my $here_quote = $1;
4959             my $delimiter = $2;
4960 0 0       0  
4961 0         0 # get here document
4962 0         0 if ($here_script eq '') {
4963             $here_script = CORE::substr $_, pos $_;
4964 0 0       0 $here_script =~ s/.*?\n//oxm;
4965 0         0 }
4966 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4967 0         0 my $heredoc = $1;
4968 0         0 my $indent = $2;
4969 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4970             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4971             push @heredoc_delimiter, qq{\\s*$delimiter};
4972 0         0 }
4973             else {
4974 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4975             }
4976             $e_string .= qq{<<"$delimiter"};
4977             }
4978              
4979 0         0 # <<~HEREDOC
4980 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4981 0         0 $slash = 'm//';
4982             my $here_quote = $1;
4983             my $delimiter = $2;
4984 0 0       0  
4985 0         0 # get here document
4986 0         0 if ($here_script eq '') {
4987             $here_script = CORE::substr $_, pos $_;
4988 0 0       0 $here_script =~ s/.*?\n//oxm;
4989 0         0 }
4990 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4991 0         0 my $heredoc = $1;
4992 0         0 my $indent = $2;
4993 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4994             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4995             push @heredoc_delimiter, qq{\\s*$delimiter};
4996 0         0 }
4997             else {
4998 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4999             }
5000             $e_string .= qq{<<$delimiter};
5001             }
5002              
5003 0         0 # <<~`HEREDOC`
5004 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
5005 0         0 $slash = 'm//';
5006             my $here_quote = $1;
5007             my $delimiter = $2;
5008 0 0       0  
5009 0         0 # get here document
5010 0         0 if ($here_script eq '') {
5011             $here_script = CORE::substr $_, pos $_;
5012 0 0       0 $here_script =~ s/.*?\n//oxm;
5013 0         0 }
5014 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5015 0         0 my $heredoc = $1;
5016 0         0 my $indent = $2;
5017 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5018             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5019             push @heredoc_delimiter, qq{\\s*$delimiter};
5020 0         0 }
5021             else {
5022 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5023             }
5024             $e_string .= qq{<<`$delimiter`};
5025             }
5026              
5027 0         0 # <<'HEREDOC'
5028 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5029 0         0 $slash = 'm//';
5030             my $here_quote = $1;
5031             my $delimiter = $2;
5032 0 0       0  
5033 0         0 # get here document
5034 0         0 if ($here_script eq '') {
5035             $here_script = CORE::substr $_, pos $_;
5036 0 0       0 $here_script =~ s/.*?\n//oxm;
5037 0         0 }
5038 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5039             push @heredoc, $1 . qq{\n$delimiter\n};
5040             push @heredoc_delimiter, $delimiter;
5041 0         0 }
5042             else {
5043 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5044             }
5045             $e_string .= $here_quote;
5046             }
5047              
5048 0         0 # <<\HEREDOC
5049 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5050 0         0 $slash = 'm//';
5051             my $here_quote = $1;
5052             my $delimiter = $2;
5053 0 0       0  
5054 0         0 # get here document
5055 0         0 if ($here_script eq '') {
5056             $here_script = CORE::substr $_, pos $_;
5057 0 0       0 $here_script =~ s/.*?\n//oxm;
5058 0         0 }
5059 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5060             push @heredoc, $1 . qq{\n$delimiter\n};
5061             push @heredoc_delimiter, $delimiter;
5062 0         0 }
5063             else {
5064 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5065             }
5066             $e_string .= $here_quote;
5067             }
5068              
5069 0         0 # <<"HEREDOC"
5070 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5071 0         0 $slash = 'm//';
5072             my $here_quote = $1;
5073             my $delimiter = $2;
5074 0 0       0  
5075 0         0 # get here document
5076 0         0 if ($here_script eq '') {
5077             $here_script = CORE::substr $_, pos $_;
5078 0 0       0 $here_script =~ s/.*?\n//oxm;
5079 0         0 }
5080 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5081             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5082             push @heredoc_delimiter, $delimiter;
5083 0         0 }
5084             else {
5085 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5086             }
5087             $e_string .= $here_quote;
5088             }
5089              
5090 0         0 # <
5091 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5092 0         0 $slash = 'm//';
5093             my $here_quote = $1;
5094             my $delimiter = $2;
5095 0 0       0  
5096 0         0 # get here document
5097 0         0 if ($here_script eq '') {
5098             $here_script = CORE::substr $_, pos $_;
5099 0 0       0 $here_script =~ s/.*?\n//oxm;
5100 0         0 }
5101 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5102             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5103             push @heredoc_delimiter, $delimiter;
5104 0         0 }
5105             else {
5106 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5107             }
5108             $e_string .= $here_quote;
5109             }
5110              
5111 0         0 # <<`HEREDOC`
5112 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5113 0         0 $slash = 'm//';
5114             my $here_quote = $1;
5115             my $delimiter = $2;
5116 0 0       0  
5117 0         0 # get here document
5118 0         0 if ($here_script eq '') {
5119             $here_script = CORE::substr $_, pos $_;
5120 0 0       0 $here_script =~ s/.*?\n//oxm;
5121 0         0 }
5122 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5123             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5124             push @heredoc_delimiter, $delimiter;
5125 0         0 }
5126             else {
5127 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5128             }
5129             $e_string .= $here_quote;
5130             }
5131              
5132             # any operator before div
5133             elsif ($string =~ /\G (
5134             -- | \+\+ |
5135 0         0 [\)\}\]]
  18         31  
5136              
5137             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5138              
5139             # yada-yada or triple-dot operator
5140             elsif ($string =~ /\G (
5141 18         51 \.\.\.
  0         0  
5142              
5143             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5144              
5145             # any operator before m//
5146             elsif ($string =~ /\G ((?>
5147              
5148             !~~ | !~ | != | ! |
5149             %= | % |
5150             &&= | && | &= | &\.= | &\. | & |
5151             -= | -> | - |
5152             :(?>\s*)= |
5153             : |
5154             <<>> |
5155             <<= | <=> | <= | < |
5156             == | => | =~ | = |
5157             >>= | >> | >= | > |
5158             \*\*= | \*\* | \*= | \* |
5159             \+= | \+ |
5160             \.\. | \.= | \. |
5161             \/\/= | \/\/ |
5162             \/= | \/ |
5163             \? |
5164             \\ |
5165             \^= | \^\.= | \^\. | \^ |
5166             \b x= |
5167             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5168             ~~ | ~\. | ~ |
5169             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5170             \b(?: print )\b |
5171              
5172 0         0 [,;\(\{\[]
  31         60  
5173              
5174             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5175 31         107  
5176             # other any character
5177             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5178              
5179 131         557 # system error
5180             else {
5181             die __FILE__, ": Oops, this shouldn't happen!\n";
5182             }
5183 0         0 }
5184              
5185             return $e_string;
5186             }
5187              
5188             #
5189             # character class
5190 17     1919 0 69 #
5191             sub character_class {
5192 1919 100       3426 my($char,$modifier) = @_;
5193 1919 100       3895  
5194 52         98 if ($char eq '.') {
5195             if ($modifier =~ /s/) {
5196             return '${Elatin10::dot_s}';
5197 17         37 }
5198             else {
5199             return '${Elatin10::dot}';
5200             }
5201 35         76 }
5202             else {
5203             return Elatin10::classic_character_class($char);
5204             }
5205             }
5206              
5207             #
5208             # escape capture ($1, $2, $3, ...)
5209             #
5210 1867     212 0 3151 sub e_capture {
5211              
5212             return join '', '${', $_[0], '}';
5213             }
5214              
5215             #
5216             # escape transliteration (tr/// or y///)
5217 212     3 0 789 #
5218 3         16 sub e_tr {
5219 3   50     6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5220             my $e_tr = '';
5221 3         6 $modifier ||= '';
5222              
5223             $slash = 'div';
5224 3         4  
5225             # quote character class 1
5226             $charclass = q_tr($charclass);
5227 3         6  
5228             # quote character class 2
5229             $charclass2 = q_tr($charclass2);
5230 3 50       9  
5231 3 0       9 # /b /B modifier
5232 0         0 if ($modifier =~ tr/bB//d) {
5233             if ($variable eq '') {
5234             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5235 0         0 }
5236             else {
5237             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5238             }
5239 0 100       0 }
5240 3         7 else {
5241             if ($variable eq '') {
5242             $e_tr = qq{Elatin10::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5243 2         7 }
5244             else {
5245             $e_tr = qq{Elatin10::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5246             }
5247             }
5248 1         5  
5249 3         5 # clear tr/// variable
5250             $tr_variable = '';
5251 3         4 $bind_operator = '';
5252              
5253             return $e_tr;
5254             }
5255              
5256             #
5257             # quote for escape transliteration (tr/// or y///)
5258 3     6 0 24 #
5259             sub q_tr {
5260             my($charclass) = @_;
5261 6 50       9  
    0          
    0          
    0          
    0          
    0          
5262 6         13 # quote character class
5263             if ($charclass !~ /'/oxms) {
5264             return e_q('', "'", "'", $charclass); # --> q' '
5265 6         9 }
5266             elsif ($charclass !~ /\//oxms) {
5267             return e_q('q', '/', '/', $charclass); # --> q/ /
5268 0         0 }
5269             elsif ($charclass !~ /\#/oxms) {
5270             return e_q('q', '#', '#', $charclass); # --> q# #
5271 0         0 }
5272             elsif ($charclass !~ /[\<\>]/oxms) {
5273             return e_q('q', '<', '>', $charclass); # --> q< >
5274 0         0 }
5275             elsif ($charclass !~ /[\(\)]/oxms) {
5276             return e_q('q', '(', ')', $charclass); # --> q( )
5277 0         0 }
5278             elsif ($charclass !~ /[\{\}]/oxms) {
5279             return e_q('q', '{', '}', $charclass); # --> q{ }
5280 0         0 }
5281 0 0       0 else {
5282 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5283             if ($charclass !~ /\Q$char\E/xms) {
5284             return e_q('q', $char, $char, $charclass);
5285             }
5286             }
5287 0         0 }
5288              
5289             return e_q('q', '{', '}', $charclass);
5290             }
5291              
5292             #
5293             # escape q string (q//, '')
5294 0     1264 0 0 #
5295             sub e_q {
5296 1264         3146 my($ope,$delimiter,$end_delimiter,$string) = @_;
5297              
5298 1264         1695 $slash = 'div';
5299              
5300             return join '', $ope, $delimiter, $string, $end_delimiter;
5301             }
5302              
5303             #
5304             # escape qq string (qq//, "", qx//, ``)
5305 1264     4092 0 6293 #
5306             sub e_qq {
5307 4092         9105 my($ope,$delimiter,$end_delimiter,$string) = @_;
5308              
5309 4092         5530 $slash = 'div';
5310 4092         5708  
5311             my $left_e = 0;
5312             my $right_e = 0;
5313 4092         4662  
5314             # split regexp
5315             my @char = $string =~ /\G((?>
5316             [^\\\$] |
5317             \\x\{ (?>[0-9A-Fa-f]+) \} |
5318             \\o\{ (?>[0-7]+) \} |
5319             \\N\{ (?>[^0-9\}][^\}]*) \} |
5320             \\ $q_char |
5321             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5322             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5323             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5324             \$ (?>\s* [0-9]+) |
5325             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5326             \$ \$ (?![\w\{]) |
5327             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5328             $q_char
5329 4092         155510 ))/oxmsg;
5330              
5331             for (my $i=0; $i <= $#char; $i++) {
5332 4092 50 33     12661  
    50 33        
    100          
    100          
    50          
5333 114125         366856 # "\L\u" --> "\u\L"
5334             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5335             @char[$i,$i+1] = @char[$i+1,$i];
5336             }
5337              
5338 0         0 # "\U\l" --> "\l\U"
5339             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5340             @char[$i,$i+1] = @char[$i+1,$i];
5341             }
5342              
5343 0         0 # octal escape sequence
5344             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5345             $char[$i] = Elatin10::octchr($1);
5346             }
5347              
5348 1         4 # hexadecimal escape sequence
5349             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5350             $char[$i] = Elatin10::hexchr($1);
5351             }
5352              
5353 1         3 # \N{CHARNAME} --> N{CHARNAME}
5354             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5355             $char[$i] = $1;
5356 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          
5357              
5358             if (0) {
5359             }
5360              
5361             # \F
5362             #
5363             # P.69 Table 2-6. Translation escapes
5364             # in Chapter 2: Bits and Pieces
5365             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5366             # (and so on)
5367 114125         913017  
5368 0 50       0 # \u \l \U \L \F \Q \E
5369 484         1091 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5370             if ($right_e < $left_e) {
5371             $char[$i] = '\\' . $char[$i];
5372             }
5373             }
5374             elsif ($char[$i] eq '\u') {
5375              
5376             # "STRING @{[ LIST EXPR ]} MORE STRING"
5377              
5378             # P.257 Other Tricks You Can Do with Hard References
5379             # in Chapter 8: References
5380             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5381              
5382             # P.353 Other Tricks You Can Do with Hard References
5383             # in Chapter 8: References
5384             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5385              
5386 0         0 # (and so on)
5387 0         0  
5388             $char[$i] = '@{[Elatin10::ucfirst qq<';
5389             $left_e++;
5390 0         0 }
5391 0         0 elsif ($char[$i] eq '\l') {
5392             $char[$i] = '@{[Elatin10::lcfirst qq<';
5393             $left_e++;
5394 0         0 }
5395 0         0 elsif ($char[$i] eq '\U') {
5396             $char[$i] = '@{[Elatin10::uc qq<';
5397             $left_e++;
5398 0         0 }
5399 0         0 elsif ($char[$i] eq '\L') {
5400             $char[$i] = '@{[Elatin10::lc qq<';
5401             $left_e++;
5402 0         0 }
5403 24         35 elsif ($char[$i] eq '\F') {
5404             $char[$i] = '@{[Elatin10::fc qq<';
5405             $left_e++;
5406 24         41 }
5407 0         0 elsif ($char[$i] eq '\Q') {
5408             $char[$i] = '@{[CORE::quotemeta qq<';
5409             $left_e++;
5410 0 50       0 }
5411 24         37 elsif ($char[$i] eq '\E') {
5412 24         30 if ($right_e < $left_e) {
5413             $char[$i] = '>]}';
5414             $right_e++;
5415 24         38 }
5416             else {
5417             $char[$i] = '';
5418             }
5419 0         0 }
5420 0 0       0 elsif ($char[$i] eq '\Q') {
5421 0         0 while (1) {
5422             if (++$i > $#char) {
5423 0 0       0 last;
5424 0         0 }
5425             if ($char[$i] eq '\E') {
5426             last;
5427             }
5428             }
5429             }
5430             elsif ($char[$i] eq '\E') {
5431             }
5432              
5433             # $0 --> $0
5434             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5435             }
5436             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5437             }
5438              
5439             # $$ --> $$
5440             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5441             }
5442              
5443             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5444 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5445             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5446             $char[$i] = e_capture($1);
5447 205         447 }
5448             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5449             $char[$i] = e_capture($1);
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_bracket)*? \] ) \z/oxms) {
5454             $char[$i] = e_capture($1.'->'.$2);
5455             }
5456              
5457 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5458             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5459             $char[$i] = e_capture($1.'->'.$2);
5460             }
5461              
5462 0         0 # $$foo
5463             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5464             $char[$i] = e_capture($1);
5465             }
5466              
5467 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5468             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5469             $char[$i] = '@{[Elatin10::PREMATCH()]}';
5470             }
5471              
5472 44         121 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5473             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5474             $char[$i] = '@{[Elatin10::MATCH()]}';
5475             }
5476              
5477 45         117 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5478             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5479             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5480             }
5481              
5482             # ${ foo } --> ${ foo }
5483             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5484             }
5485              
5486 33         124 # ${ ... }
5487             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5488             $char[$i] = e_capture($1);
5489             }
5490             }
5491 0 50       0  
5492 4092         8161 # return string
5493             if ($left_e > $right_e) {
5494 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5495             }
5496             return join '', $ope, $delimiter, @char, $end_delimiter;
5497             }
5498              
5499             #
5500             # escape qw string (qw//)
5501 4092     16 0 33097 #
5502             sub e_qw {
5503 16         77 my($ope,$delimiter,$end_delimiter,$string) = @_;
5504              
5505             $slash = 'div';
5506 16         31  
  16         211  
5507 483 50       731 # choice again delimiter
    0          
    0          
    0          
    0          
5508 16         96 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5509             if (not $octet{$end_delimiter}) {
5510             return join '', $ope, $delimiter, $string, $end_delimiter;
5511 16         121 }
5512             elsif (not $octet{')'}) {
5513             return join '', $ope, '(', $string, ')';
5514 0         0 }
5515             elsif (not $octet{'}'}) {
5516             return join '', $ope, '{', $string, '}';
5517 0         0 }
5518             elsif (not $octet{']'}) {
5519             return join '', $ope, '[', $string, ']';
5520 0         0 }
5521             elsif (not $octet{'>'}) {
5522             return join '', $ope, '<', $string, '>';
5523 0         0 }
5524 0 0       0 else {
5525 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5526             if (not $octet{$char}) {
5527             return join '', $ope, $char, $string, $char;
5528             }
5529             }
5530             }
5531 0         0  
5532 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5533 0         0 my @string = CORE::split(/\s+/, $string);
5534 0         0 for my $string (@string) {
5535 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5536 0         0 for my $octet (@octet) {
5537             if ($octet =~ /\A (['\\]) \z/oxms) {
5538             $octet = '\\' . $1;
5539 0         0 }
5540             }
5541 0         0 $string = join '', @octet;
  0         0  
5542             }
5543             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5544             }
5545              
5546             #
5547             # escape here document (<<"HEREDOC", <
5548 0     93 0 0 #
5549             sub e_heredoc {
5550 93         252 my($string) = @_;
5551              
5552 93         149 $slash = 'm//';
5553              
5554 93         316 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5555 93         146  
5556             my $left_e = 0;
5557             my $right_e = 0;
5558 93         124  
5559             # split regexp
5560             my @char = $string =~ /\G((?>
5561             [^\\\$] |
5562             \\x\{ (?>[0-9A-Fa-f]+) \} |
5563             \\o\{ (?>[0-7]+) \} |
5564             \\N\{ (?>[^0-9\}][^\}]*) \} |
5565             \\ $q_char |
5566             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5567             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5568             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5569             \$ (?>\s* [0-9]+) |
5570             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5571             \$ \$ (?![\w\{]) |
5572             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5573             $q_char
5574 93         8216 ))/oxmsg;
5575              
5576             for (my $i=0; $i <= $#char; $i++) {
5577 93 50 33     427  
    50 33        
    100          
    100          
    50          
5578 3203         10221 # "\L\u" --> "\u\L"
5579             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5580             @char[$i,$i+1] = @char[$i+1,$i];
5581             }
5582              
5583 0         0 # "\U\l" --> "\l\U"
5584             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5585             @char[$i,$i+1] = @char[$i+1,$i];
5586             }
5587              
5588 0         0 # octal escape sequence
5589             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5590             $char[$i] = Elatin10::octchr($1);
5591             }
5592              
5593 1         3 # hexadecimal escape sequence
5594             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5595             $char[$i] = Elatin10::hexchr($1);
5596             }
5597              
5598 1         3 # \N{CHARNAME} --> N{CHARNAME}
5599             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5600             $char[$i] = $1;
5601 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          
5602              
5603             if (0) {
5604             }
5605 3203         27864  
5606 0 0       0 # \u \l \U \L \F \Q \E
5607 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5608             if ($right_e < $left_e) {
5609             $char[$i] = '\\' . $char[$i];
5610             }
5611 0         0 }
5612 0         0 elsif ($char[$i] eq '\u') {
5613             $char[$i] = '@{[Elatin10::ucfirst qq<';
5614             $left_e++;
5615 0         0 }
5616 0         0 elsif ($char[$i] eq '\l') {
5617             $char[$i] = '@{[Elatin10::lcfirst qq<';
5618             $left_e++;
5619 0         0 }
5620 0         0 elsif ($char[$i] eq '\U') {
5621             $char[$i] = '@{[Elatin10::uc qq<';
5622             $left_e++;
5623 0         0 }
5624 0         0 elsif ($char[$i] eq '\L') {
5625             $char[$i] = '@{[Elatin10::lc qq<';
5626             $left_e++;
5627 0         0 }
5628 0         0 elsif ($char[$i] eq '\F') {
5629             $char[$i] = '@{[Elatin10::fc qq<';
5630             $left_e++;
5631 0         0 }
5632 0         0 elsif ($char[$i] eq '\Q') {
5633             $char[$i] = '@{[CORE::quotemeta qq<';
5634             $left_e++;
5635 0 0       0 }
5636 0         0 elsif ($char[$i] eq '\E') {
5637 0         0 if ($right_e < $left_e) {
5638             $char[$i] = '>]}';
5639             $right_e++;
5640 0         0 }
5641             else {
5642             $char[$i] = '';
5643             }
5644 0         0 }
5645 0 0       0 elsif ($char[$i] eq '\Q') {
5646 0         0 while (1) {
5647             if (++$i > $#char) {
5648 0 0       0 last;
5649 0         0 }
5650             if ($char[$i] eq '\E') {
5651             last;
5652             }
5653             }
5654             }
5655             elsif ($char[$i] eq '\E') {
5656             }
5657              
5658             # $0 --> $0
5659             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5660             }
5661             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5662             }
5663              
5664             # $$ --> $$
5665             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5666             }
5667              
5668             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5669 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5670             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5671             $char[$i] = e_capture($1);
5672 0         0 }
5673             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5674             $char[$i] = e_capture($1);
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_bracket)*? \] ) \z/oxms) {
5679             $char[$i] = e_capture($1.'->'.$2);
5680             }
5681              
5682 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5683             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5684             $char[$i] = e_capture($1.'->'.$2);
5685             }
5686              
5687 0         0 # $$foo
5688             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5689             $char[$i] = e_capture($1);
5690             }
5691              
5692 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5693             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5694             $char[$i] = '@{[Elatin10::PREMATCH()]}';
5695             }
5696              
5697 8         50 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5698             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5699             $char[$i] = '@{[Elatin10::MATCH()]}';
5700             }
5701              
5702 8         43 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5703             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5704             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5705             }
5706              
5707             # ${ foo } --> ${ foo }
5708             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5709             }
5710              
5711 6         48 # ${ ... }
5712             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5713             $char[$i] = e_capture($1);
5714             }
5715             }
5716 0 50       0  
5717 93         205 # return string
5718             if ($left_e > $right_e) {
5719 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5720             }
5721             return join '', @char;
5722             }
5723              
5724             #
5725             # escape regexp (m//, qr//)
5726 93     652 0 731 #
5727 652   100     2854 sub e_qr {
5728             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5729 652         2715 $modifier ||= '';
5730 652 50       1109  
5731 652         1474 $modifier =~ tr/p//d;
5732 0         0 if ($modifier =~ /([adlu])/oxms) {
5733 0 0       0 my $line = 0;
5734 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5735 0         0 if ($filename ne __FILE__) {
5736             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5737             last;
5738 0         0 }
5739             }
5740             die qq{Unsupported modifier "$1" used at line $line.\n};
5741 0         0 }
5742              
5743             $slash = 'div';
5744 652 100       1048  
    100          
5745 652         2055 # literal null string pattern
5746 8         11 if ($string eq '') {
5747 8         11 $modifier =~ tr/bB//d;
5748             $modifier =~ tr/i//d;
5749             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5750             }
5751              
5752             # /b /B modifier
5753             elsif ($modifier =~ tr/bB//d) {
5754 8 50       45  
5755 2         6 # choice again delimiter
5756 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5757 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5758 0         0 my %octet = map {$_ => 1} @char;
5759 0         0 if (not $octet{')'}) {
5760             $delimiter = '(';
5761             $end_delimiter = ')';
5762 0         0 }
5763 0         0 elsif (not $octet{'}'}) {
5764             $delimiter = '{';
5765             $end_delimiter = '}';
5766 0         0 }
5767 0         0 elsif (not $octet{']'}) {
5768             $delimiter = '[';
5769             $end_delimiter = ']';
5770 0         0 }
5771 0         0 elsif (not $octet{'>'}) {
5772             $delimiter = '<';
5773             $end_delimiter = '>';
5774 0         0 }
5775 0 0       0 else {
5776 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5777 0         0 if (not $octet{$char}) {
5778 0         0 $delimiter = $char;
5779             $end_delimiter = $char;
5780             last;
5781             }
5782             }
5783             }
5784 0 50 33     0 }
5785 2         15  
5786             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5787             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5788 0         0 }
5789             else {
5790             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5791             }
5792 2 100       11 }
5793 642         1502  
5794             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5795             my $metachar = qr/[\@\\|[\]{^]/oxms;
5796 642         2369  
5797             # split regexp
5798             my @char = $string =~ /\G((?>
5799             [^\\\$\@\[\(] |
5800             \\x (?>[0-9A-Fa-f]{1,2}) |
5801             \\ (?>[0-7]{2,3}) |
5802             \\c [\x40-\x5F] |
5803             \\x\{ (?>[0-9A-Fa-f]+) \} |
5804             \\o\{ (?>[0-7]+) \} |
5805             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5806             \\ $q_char |
5807             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5808             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5809             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5810             [\$\@] $qq_variable |
5811             \$ (?>\s* [0-9]+) |
5812             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5813             \$ \$ (?![\w\{]) |
5814             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5815             \[\^ |
5816             \[\: (?>[a-z]+) :\] |
5817             \[\:\^ (?>[a-z]+) :\] |
5818             \(\? |
5819             $q_char
5820             ))/oxmsg;
5821 642 50       72599  
5822 642         2980 # choice again delimiter
  0         0  
5823 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5824 0         0 my %octet = map {$_ => 1} @char;
5825 0         0 if (not $octet{')'}) {
5826             $delimiter = '(';
5827             $end_delimiter = ')';
5828 0         0 }
5829 0         0 elsif (not $octet{'}'}) {
5830             $delimiter = '{';
5831             $end_delimiter = '}';
5832 0         0 }
5833 0         0 elsif (not $octet{']'}) {
5834             $delimiter = '[';
5835             $end_delimiter = ']';
5836 0         0 }
5837 0         0 elsif (not $octet{'>'}) {
5838             $delimiter = '<';
5839             $end_delimiter = '>';
5840 0         0 }
5841 0 0       0 else {
5842 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5843 0         0 if (not $octet{$char}) {
5844 0         0 $delimiter = $char;
5845             $end_delimiter = $char;
5846             last;
5847             }
5848             }
5849             }
5850 0         0 }
5851 642         1017  
5852 642         851 my $left_e = 0;
5853             my $right_e = 0;
5854             for (my $i=0; $i <= $#char; $i++) {
5855 642 50 66     1586  
    50 66        
    100          
    100          
    100          
    100          
5856 1872         9457 # "\L\u" --> "\u\L"
5857             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5858             @char[$i,$i+1] = @char[$i+1,$i];
5859             }
5860              
5861 0         0 # "\U\l" --> "\l\U"
5862             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5863             @char[$i,$i+1] = @char[$i+1,$i];
5864             }
5865              
5866 0         0 # octal escape sequence
5867             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5868             $char[$i] = Elatin10::octchr($1);
5869             }
5870              
5871 1         3 # hexadecimal escape sequence
5872             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5873             $char[$i] = Elatin10::hexchr($1);
5874             }
5875              
5876             # \b{...} --> b\{...}
5877             # \B{...} --> B\{...}
5878             # \N{CHARNAME} --> N\{CHARNAME}
5879             # \p{PROPERTY} --> p\{PROPERTY}
5880 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5881             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5882             $char[$i] = $1 . '\\' . $2;
5883             }
5884              
5885 6         18 # \p, \P, \X --> p, P, X
5886             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5887             $char[$i] = $1;
5888 4 100 100     12 }
    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          
5889              
5890             if (0) {
5891             }
5892 1872         5646  
5893 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5894 6         83 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5895             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)) {
5896             $char[$i] .= join '', splice @char, $i+1, 3;
5897 0         0 }
5898             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)) {
5899             $char[$i] .= join '', splice @char, $i+1, 2;
5900 0         0 }
5901             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)) {
5902             $char[$i] .= join '', splice @char, $i+1, 1;
5903             }
5904             }
5905              
5906 0         0 # open character class [...]
5907             elsif ($char[$i] eq '[') {
5908             my $left = $i;
5909              
5910             # [] make die "Unmatched [] in regexp ...\n"
5911 328 100       744 # (and so on)
5912 328         887  
5913             if ($char[$i+1] eq ']') {
5914             $i++;
5915 3         6 }
5916 328 50       418  
5917 1379         2185 while (1) {
5918             if (++$i > $#char) {
5919 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5920 1379         2293 }
5921             if ($char[$i] eq ']') {
5922             my $right = $i;
5923 328 100       396  
5924 328         1719 # [...]
  30         72  
5925             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5926             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);
5927 90         148 }
5928             else {
5929             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5930 298         1108 }
5931 328         704  
5932             $i = $left;
5933             last;
5934             }
5935             }
5936             }
5937              
5938 328         831 # open character class [^...]
5939             elsif ($char[$i] eq '[^') {
5940             my $left = $i;
5941              
5942             # [^] make die "Unmatched [] in regexp ...\n"
5943 74 100       102 # (and so on)
5944 74         172  
5945             if ($char[$i+1] eq ']') {
5946             $i++;
5947 4         7 }
5948 74 50       97  
5949 272         406 while (1) {
5950             if (++$i > $#char) {
5951 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5952 272         615 }
5953             if ($char[$i] eq ']') {
5954             my $right = $i;
5955 74 100       94  
5956 74         380 # [^...]
  30         69  
5957             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5958             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);
5959 90         156 }
5960             else {
5961             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5962 44         199 }
5963 74         148  
5964             $i = $left;
5965             last;
5966             }
5967             }
5968             }
5969              
5970 74         193 # rewrite character class or escape character
5971             elsif (my $char = character_class($char[$i],$modifier)) {
5972             $char[$i] = $char;
5973             }
5974              
5975 139 50       615 # /i modifier
5976 20         34 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
5977             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
5978             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
5979 20         40 }
5980             else {
5981             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
5982             }
5983             }
5984              
5985 0 50       0 # \u \l \U \L \F \Q \E
5986 1         4 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5987             if ($right_e < $left_e) {
5988             $char[$i] = '\\' . $char[$i];
5989             }
5990 0         0 }
5991 0         0 elsif ($char[$i] eq '\u') {
5992             $char[$i] = '@{[Elatin10::ucfirst qq<';
5993             $left_e++;
5994 0         0 }
5995 0         0 elsif ($char[$i] eq '\l') {
5996             $char[$i] = '@{[Elatin10::lcfirst qq<';
5997             $left_e++;
5998 0         0 }
5999 1         3 elsif ($char[$i] eq '\U') {
6000             $char[$i] = '@{[Elatin10::uc qq<';
6001             $left_e++;
6002 1         2 }
6003 1         2 elsif ($char[$i] eq '\L') {
6004             $char[$i] = '@{[Elatin10::lc qq<';
6005             $left_e++;
6006 1         2 }
6007 18         34 elsif ($char[$i] eq '\F') {
6008             $char[$i] = '@{[Elatin10::fc qq<';
6009             $left_e++;
6010 18         36 }
6011 1         2 elsif ($char[$i] eq '\Q') {
6012             $char[$i] = '@{[CORE::quotemeta qq<';
6013             $left_e++;
6014 1 50       3 }
6015 21         47 elsif ($char[$i] eq '\E') {
6016 21         30 if ($right_e < $left_e) {
6017             $char[$i] = '>]}';
6018             $right_e++;
6019 21         45 }
6020             else {
6021             $char[$i] = '';
6022             }
6023 0         0 }
6024 0 0       0 elsif ($char[$i] eq '\Q') {
6025 0         0 while (1) {
6026             if (++$i > $#char) {
6027 0 0       0 last;
6028 0         0 }
6029             if ($char[$i] eq '\E') {
6030             last;
6031             }
6032             }
6033             }
6034             elsif ($char[$i] eq '\E') {
6035             }
6036              
6037 0 0       0 # $0 --> $0
6038 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6039             if ($ignorecase) {
6040             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6041             }
6042 0 0       0 }
6043 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6044             if ($ignorecase) {
6045             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6046             }
6047             }
6048              
6049             # $$ --> $$
6050             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6051             }
6052              
6053             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6054 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6055 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6056 0         0 $char[$i] = e_capture($1);
6057             if ($ignorecase) {
6058             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6059             }
6060 0         0 }
6061 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6062 0         0 $char[$i] = e_capture($1);
6063             if ($ignorecase) {
6064             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6065             }
6066             }
6067              
6068 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6069 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) {
6070 0         0 $char[$i] = e_capture($1.'->'.$2);
6071             if ($ignorecase) {
6072             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6073             }
6074             }
6075              
6076 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6077 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) {
6078 0         0 $char[$i] = e_capture($1.'->'.$2);
6079             if ($ignorecase) {
6080             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6081             }
6082             }
6083              
6084 0         0 # $$foo
6085 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6086 0         0 $char[$i] = e_capture($1);
6087             if ($ignorecase) {
6088             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6089             }
6090             }
6091              
6092 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
6093 8         23 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6094             if ($ignorecase) {
6095             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
6096 0         0 }
6097             else {
6098             $char[$i] = '@{[Elatin10::PREMATCH()]}';
6099             }
6100             }
6101              
6102 8 50       24 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
6103 8         23 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6104             if ($ignorecase) {
6105             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
6106 0         0 }
6107             else {
6108             $char[$i] = '@{[Elatin10::MATCH()]}';
6109             }
6110             }
6111              
6112 8 50       24 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
6113 6         18 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6114             if ($ignorecase) {
6115             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
6116 0         0 }
6117             else {
6118             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
6119             }
6120             }
6121              
6122 6 0       16 # ${ foo }
6123 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) {
6124             if ($ignorecase) {
6125             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6126             }
6127             }
6128              
6129 0         0 # ${ ... }
6130 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6131 0         0 $char[$i] = e_capture($1);
6132             if ($ignorecase) {
6133             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6134             }
6135             }
6136              
6137 0         0 # $scalar or @array
6138 21 100       50 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6139 21         117 $char[$i] = e_string($char[$i]);
6140             if ($ignorecase) {
6141             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6142             }
6143             }
6144              
6145 11 100 33     34 # quote character before ? + * {
    50          
6146             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6147             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6148 138         1119 }
6149 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6150 0         0 my $char = $char[$i-1];
6151             if ($char[$i] eq '{') {
6152             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6153 0         0 }
6154             else {
6155             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6156             }
6157 0         0 }
6158             else {
6159             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6160             }
6161             }
6162             }
6163 127         554  
6164 642 50       1163 # make regexp string
6165 642 0 0     1467 $modifier =~ tr/i//d;
6166 0         0 if ($left_e > $right_e) {
6167             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6168             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6169 0         0 }
6170             else {
6171             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6172 0 50 33     0 }
6173 642         3303 }
6174             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6175             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6176 0         0 }
6177             else {
6178             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6179             }
6180             }
6181              
6182             #
6183             # double quote stuff
6184 642     180 0 5477 #
6185             sub qq_stuff {
6186             my($delimiter,$end_delimiter,$stuff) = @_;
6187 180 100       264  
6188 180         383 # scalar variable or array variable
6189             if ($stuff =~ /\A [\$\@] /oxms) {
6190             return $stuff;
6191             }
6192 100         396  
  80         191  
6193 80         240 # quote by delimiter
6194 80 50       199 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6195 80 50       139 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6196 80 50       118 next if $char eq $delimiter;
6197 80         144 next if $char eq $end_delimiter;
6198             if (not $octet{$char}) {
6199             return join '', 'qq', $char, $stuff, $char;
6200 80         530 }
6201             }
6202             return join '', 'qq', '<', $stuff, '>';
6203             }
6204              
6205             #
6206             # escape regexp (m'', qr'', and m''b, qr''b)
6207 0     10 0 0 #
6208 10   50     45 sub e_qr_q {
6209             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6210 10         46 $modifier ||= '';
6211 10 50       14  
6212 10         26 $modifier =~ tr/p//d;
6213 0         0 if ($modifier =~ /([adlu])/oxms) {
6214 0 0       0 my $line = 0;
6215 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6216 0         0 if ($filename ne __FILE__) {
6217             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6218             last;
6219 0         0 }
6220             }
6221             die qq{Unsupported modifier "$1" used at line $line.\n};
6222 0         0 }
6223              
6224             $slash = 'div';
6225 10 100       16  
    50          
6226 10         23 # literal null string pattern
6227 8         10 if ($string eq '') {
6228 8         12 $modifier =~ tr/bB//d;
6229             $modifier =~ tr/i//d;
6230             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6231             }
6232              
6233 8         39 # with /b /B modifier
6234             elsif ($modifier =~ tr/bB//d) {
6235             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6236             }
6237              
6238 0         0 # without /b /B modifier
6239             else {
6240             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6241             }
6242             }
6243              
6244             #
6245             # escape regexp (m'', qr'')
6246 2     2 0 9 #
6247             sub e_qr_qt {
6248 2 50       7 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6249              
6250             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6251 2         7  
6252             # split regexp
6253             my @char = $string =~ /\G((?>
6254             [^\\\[\$\@\/] |
6255             [\x00-\xFF] |
6256             \[\^ |
6257             \[\: (?>[a-z]+) \:\] |
6258             \[\:\^ (?>[a-z]+) \:\] |
6259             [\$\@\/] |
6260             \\ (?:$q_char) |
6261             (?:$q_char)
6262             ))/oxmsg;
6263 2         69  
6264 2 50 33     12 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6265             for (my $i=0; $i <= $#char; $i++) {
6266             if (0) {
6267             }
6268 2         19  
6269 0         0 # open character class [...]
6270 0 0       0 elsif ($char[$i] eq '[') {
6271 0         0 my $left = $i;
6272             if ($char[$i+1] eq ']') {
6273 0         0 $i++;
6274 0 0       0 }
6275 0         0 while (1) {
6276             if (++$i > $#char) {
6277 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6278 0         0 }
6279             if ($char[$i] eq ']') {
6280             my $right = $i;
6281 0         0  
6282             # [...]
6283 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6284 0         0  
6285             $i = $left;
6286             last;
6287             }
6288             }
6289             }
6290              
6291 0         0 # open character class [^...]
6292 0 0       0 elsif ($char[$i] eq '[^') {
6293 0         0 my $left = $i;
6294             if ($char[$i+1] eq ']') {
6295 0         0 $i++;
6296 0 0       0 }
6297 0         0 while (1) {
6298             if (++$i > $#char) {
6299 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6300 0         0 }
6301             if ($char[$i] eq ']') {
6302             my $right = $i;
6303 0         0  
6304             # [^...]
6305 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6306 0         0  
6307             $i = $left;
6308             last;
6309             }
6310             }
6311             }
6312              
6313 0         0 # escape $ @ / and \
6314             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6315             $char[$i] = '\\' . $char[$i];
6316             }
6317              
6318 0         0 # rewrite character class or escape character
6319             elsif (my $char = character_class($char[$i],$modifier)) {
6320             $char[$i] = $char;
6321             }
6322              
6323 0 0       0 # /i modifier
6324 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6325             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6326             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6327 0         0 }
6328             else {
6329             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6330             }
6331             }
6332              
6333 0 0       0 # quote character before ? + * {
6334             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6335             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6336 0         0 }
6337             else {
6338             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6339             }
6340             }
6341 0         0 }
6342 2         4  
6343             $delimiter = '/';
6344 2         5 $end_delimiter = '/';
6345 2         4  
6346             $modifier =~ tr/i//d;
6347             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6348             }
6349              
6350             #
6351             # escape regexp (m''b, qr''b)
6352 2     0 0 14 #
6353             sub e_qr_qb {
6354             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6355 0         0  
6356             # split regexp
6357             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6358 0         0  
6359 0 0       0 # unescape character
    0          
6360             for (my $i=0; $i <= $#char; $i++) {
6361             if (0) {
6362             }
6363 0         0  
6364             # remain \\
6365             elsif ($char[$i] eq '\\\\') {
6366             }
6367              
6368 0         0 # escape $ @ / and \
6369             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6370             $char[$i] = '\\' . $char[$i];
6371             }
6372 0         0 }
6373 0         0  
6374 0         0 $delimiter = '/';
6375             $end_delimiter = '/';
6376             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6377             }
6378              
6379             #
6380             # escape regexp (s/here//)
6381 0     76 0 0 #
6382 76   100     246 sub e_s1 {
6383             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6384 76         359 $modifier ||= '';
6385 76 50       111  
6386 76         201 $modifier =~ tr/p//d;
6387 0         0 if ($modifier =~ /([adlu])/oxms) {
6388 0 0       0 my $line = 0;
6389 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6390 0         0 if ($filename ne __FILE__) {
6391             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6392             last;
6393 0         0 }
6394             }
6395             die qq{Unsupported modifier "$1" used at line $line.\n};
6396 0         0 }
6397              
6398             $slash = 'div';
6399 76 100       126  
    50          
6400 76         280 # literal null string pattern
6401 8         9 if ($string eq '') {
6402 8         13 $modifier =~ tr/bB//d;
6403             $modifier =~ tr/i//d;
6404             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6405             }
6406              
6407             # /b /B modifier
6408             elsif ($modifier =~ tr/bB//d) {
6409 8 0       56  
6410 0         0 # choice again delimiter
6411 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6412 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6413 0         0 my %octet = map {$_ => 1} @char;
6414 0         0 if (not $octet{')'}) {
6415             $delimiter = '(';
6416             $end_delimiter = ')';
6417 0         0 }
6418 0         0 elsif (not $octet{'}'}) {
6419             $delimiter = '{';
6420             $end_delimiter = '}';
6421 0         0 }
6422 0         0 elsif (not $octet{']'}) {
6423             $delimiter = '[';
6424             $end_delimiter = ']';
6425 0         0 }
6426 0         0 elsif (not $octet{'>'}) {
6427             $delimiter = '<';
6428             $end_delimiter = '>';
6429 0         0 }
6430 0 0       0 else {
6431 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6432 0         0 if (not $octet{$char}) {
6433 0         0 $delimiter = $char;
6434             $end_delimiter = $char;
6435             last;
6436             }
6437             }
6438             }
6439 0         0 }
6440 0         0  
6441             my $prematch = '';
6442             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6443 0 100       0 }
6444 68         197  
6445             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6446             my $metachar = qr/[\@\\|[\]{^]/oxms;
6447 68         307  
6448             # split regexp
6449             my @char = $string =~ /\G((?>
6450             [^\\\$\@\[\(] |
6451             \\ (?>[1-9][0-9]*) |
6452             \\g (?>\s*) (?>[1-9][0-9]*) |
6453             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6454             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6455             \\x (?>[0-9A-Fa-f]{1,2}) |
6456             \\ (?>[0-7]{2,3}) |
6457             \\c [\x40-\x5F] |
6458             \\x\{ (?>[0-9A-Fa-f]+) \} |
6459             \\o\{ (?>[0-7]+) \} |
6460             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6461             \\ $q_char |
6462             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6463             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6464             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6465             [\$\@] $qq_variable |
6466             \$ (?>\s* [0-9]+) |
6467             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6468             \$ \$ (?![\w\{]) |
6469             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6470             \[\^ |
6471             \[\: (?>[a-z]+) :\] |
6472             \[\:\^ (?>[a-z]+) :\] |
6473             \(\? |
6474             $q_char
6475             ))/oxmsg;
6476 68 50       17024  
6477 68         454 # choice again delimiter
  0         0  
6478 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6479 0         0 my %octet = map {$_ => 1} @char;
6480 0         0 if (not $octet{')'}) {
6481             $delimiter = '(';
6482             $end_delimiter = ')';
6483 0         0 }
6484 0         0 elsif (not $octet{'}'}) {
6485             $delimiter = '{';
6486             $end_delimiter = '}';
6487 0         0 }
6488 0         0 elsif (not $octet{']'}) {
6489             $delimiter = '[';
6490             $end_delimiter = ']';
6491 0         0 }
6492 0         0 elsif (not $octet{'>'}) {
6493             $delimiter = '<';
6494             $end_delimiter = '>';
6495 0         0 }
6496 0 0       0 else {
6497 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6498 0         0 if (not $octet{$char}) {
6499 0         0 $delimiter = $char;
6500             $end_delimiter = $char;
6501             last;
6502             }
6503             }
6504             }
6505             }
6506 0         0  
  68         139  
6507             # count '('
6508 253         524 my $parens = grep { $_ eq '(' } @char;
6509 68         110  
6510 68         100 my $left_e = 0;
6511             my $right_e = 0;
6512             for (my $i=0; $i <= $#char; $i++) {
6513 68 50 33     187  
    50 33        
    100          
    100          
    50          
    50          
6514 195         1370 # "\L\u" --> "\u\L"
6515             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6516             @char[$i,$i+1] = @char[$i+1,$i];
6517             }
6518              
6519 0         0 # "\U\l" --> "\l\U"
6520             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6521             @char[$i,$i+1] = @char[$i+1,$i];
6522             }
6523              
6524 0         0 # octal escape sequence
6525             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6526             $char[$i] = Elatin10::octchr($1);
6527             }
6528              
6529 1         3 # hexadecimal escape sequence
6530             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6531             $char[$i] = Elatin10::hexchr($1);
6532             }
6533              
6534             # \b{...} --> b\{...}
6535             # \B{...} --> B\{...}
6536             # \N{CHARNAME} --> N\{CHARNAME}
6537             # \p{PROPERTY} --> p\{PROPERTY}
6538 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6539             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6540             $char[$i] = $1 . '\\' . $2;
6541             }
6542              
6543 0         0 # \p, \P, \X --> p, P, X
6544             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6545             $char[$i] = $1;
6546 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          
6547              
6548             if (0) {
6549             }
6550 195         726  
6551 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6552 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6553             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)) {
6554             $char[$i] .= join '', splice @char, $i+1, 3;
6555 0         0 }
6556             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)) {
6557             $char[$i] .= join '', splice @char, $i+1, 2;
6558 0         0 }
6559             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)) {
6560             $char[$i] .= join '', splice @char, $i+1, 1;
6561             }
6562             }
6563              
6564 0         0 # open character class [...]
6565 13 50       19 elsif ($char[$i] eq '[') {
6566 13         47 my $left = $i;
6567             if ($char[$i+1] eq ']') {
6568 0         0 $i++;
6569 13 50       19 }
6570 58         89 while (1) {
6571             if (++$i > $#char) {
6572 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6573 58         117 }
6574             if ($char[$i] eq ']') {
6575             my $right = $i;
6576 13 50       21  
6577 13         76 # [...]
  0         0  
6578             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6579             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);
6580 0         0 }
6581             else {
6582             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6583 13         51 }
6584 13         23  
6585             $i = $left;
6586             last;
6587             }
6588             }
6589             }
6590              
6591 13         34 # open character class [^...]
6592 0 0       0 elsif ($char[$i] eq '[^') {
6593 0         0 my $left = $i;
6594             if ($char[$i+1] eq ']') {
6595 0         0 $i++;
6596 0 0       0 }
6597 0         0 while (1) {
6598             if (++$i > $#char) {
6599 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6600 0         0 }
6601             if ($char[$i] eq ']') {
6602             my $right = $i;
6603 0 0       0  
6604 0         0 # [^...]
  0         0  
6605             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6606             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);
6607 0         0 }
6608             else {
6609             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6610 0         0 }
6611 0         0  
6612             $i = $left;
6613             last;
6614             }
6615             }
6616             }
6617              
6618 0         0 # rewrite character class or escape character
6619             elsif (my $char = character_class($char[$i],$modifier)) {
6620             $char[$i] = $char;
6621             }
6622              
6623 7 50       17 # /i modifier
6624 3         7 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6625             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6626             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6627 3         13 }
6628             else {
6629             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6630             }
6631             }
6632              
6633 0 0       0 # \u \l \U \L \F \Q \E
6634 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6635             if ($right_e < $left_e) {
6636             $char[$i] = '\\' . $char[$i];
6637             }
6638 0         0 }
6639 0         0 elsif ($char[$i] eq '\u') {
6640             $char[$i] = '@{[Elatin10::ucfirst qq<';
6641             $left_e++;
6642 0         0 }
6643 0         0 elsif ($char[$i] eq '\l') {
6644             $char[$i] = '@{[Elatin10::lcfirst qq<';
6645             $left_e++;
6646 0         0 }
6647 0         0 elsif ($char[$i] eq '\U') {
6648             $char[$i] = '@{[Elatin10::uc qq<';
6649             $left_e++;
6650 0         0 }
6651 0         0 elsif ($char[$i] eq '\L') {
6652             $char[$i] = '@{[Elatin10::lc qq<';
6653             $left_e++;
6654 0         0 }
6655 0         0 elsif ($char[$i] eq '\F') {
6656             $char[$i] = '@{[Elatin10::fc qq<';
6657             $left_e++;
6658 0         0 }
6659 0         0 elsif ($char[$i] eq '\Q') {
6660             $char[$i] = '@{[CORE::quotemeta qq<';
6661             $left_e++;
6662 0 0       0 }
6663 0         0 elsif ($char[$i] eq '\E') {
6664 0         0 if ($right_e < $left_e) {
6665             $char[$i] = '>]}';
6666             $right_e++;
6667 0         0 }
6668             else {
6669             $char[$i] = '';
6670             }
6671 0         0 }
6672 0 0       0 elsif ($char[$i] eq '\Q') {
6673 0         0 while (1) {
6674             if (++$i > $#char) {
6675 0 0       0 last;
6676 0         0 }
6677             if ($char[$i] eq '\E') {
6678             last;
6679             }
6680             }
6681             }
6682             elsif ($char[$i] eq '\E') {
6683             }
6684              
6685             # \0 --> \0
6686             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6687             }
6688              
6689             # \g{N}, \g{-N}
6690              
6691             # P.108 Using Simple Patterns
6692             # in Chapter 7: In the World of Regular Expressions
6693             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6694              
6695             # P.221 Capturing
6696             # in Chapter 5: Pattern Matching
6697             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6698              
6699             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6700             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6701             }
6702              
6703             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6704             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6705             }
6706              
6707             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6708             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6709             }
6710              
6711             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6712             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6713             }
6714              
6715 0 0       0 # $0 --> $0
6716 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6717             if ($ignorecase) {
6718             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6719             }
6720 0 0       0 }
6721 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6722             if ($ignorecase) {
6723             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6724             }
6725             }
6726              
6727             # $$ --> $$
6728             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6729             }
6730              
6731             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6732 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6733 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6734 0         0 $char[$i] = e_capture($1);
6735             if ($ignorecase) {
6736             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6737             }
6738 0         0 }
6739 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6740 0         0 $char[$i] = e_capture($1);
6741             if ($ignorecase) {
6742             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6743             }
6744             }
6745              
6746 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6747 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) {
6748 0         0 $char[$i] = e_capture($1.'->'.$2);
6749             if ($ignorecase) {
6750             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6751             }
6752             }
6753              
6754 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6755 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) {
6756 0         0 $char[$i] = e_capture($1.'->'.$2);
6757             if ($ignorecase) {
6758             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6759             }
6760             }
6761              
6762 0         0 # $$foo
6763 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6764 0         0 $char[$i] = e_capture($1);
6765             if ($ignorecase) {
6766             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6767             }
6768             }
6769              
6770 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
6771 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6772             if ($ignorecase) {
6773             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
6774 0         0 }
6775             else {
6776             $char[$i] = '@{[Elatin10::PREMATCH()]}';
6777             }
6778             }
6779              
6780 4 50       15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
6781 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6782             if ($ignorecase) {
6783             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
6784 0         0 }
6785             else {
6786             $char[$i] = '@{[Elatin10::MATCH()]}';
6787             }
6788             }
6789              
6790 4 50       16 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
6791 3         12 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6792             if ($ignorecase) {
6793             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
6794 0         0 }
6795             else {
6796             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
6797             }
6798             }
6799              
6800 3 0       11 # ${ foo }
6801 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) {
6802             if ($ignorecase) {
6803             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6804             }
6805             }
6806              
6807 0         0 # ${ ... }
6808 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6809 0         0 $char[$i] = e_capture($1);
6810             if ($ignorecase) {
6811             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6812             }
6813             }
6814              
6815 0         0 # $scalar or @array
6816 4 50       31 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6817 4         21 $char[$i] = e_string($char[$i]);
6818             if ($ignorecase) {
6819             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6820             }
6821             }
6822              
6823 0 50       0 # quote character before ? + * {
6824             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6825             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6826 13         65 }
6827             else {
6828             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6829             }
6830             }
6831             }
6832 13         63  
6833 68         165 # make regexp string
6834 68 50       114 my $prematch = '';
6835 68         180 $modifier =~ tr/i//d;
6836             if ($left_e > $right_e) {
6837 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6838             }
6839             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6840             }
6841              
6842             #
6843             # escape regexp (s'here'' or s'here''b)
6844 68     21 0 822 #
6845 21   100     121 sub e_s1_q {
6846             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6847 21         75 $modifier ||= '';
6848 21 50       28  
6849 21         51 $modifier =~ tr/p//d;
6850 0         0 if ($modifier =~ /([adlu])/oxms) {
6851 0 0       0 my $line = 0;
6852 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6853 0         0 if ($filename ne __FILE__) {
6854             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6855             last;
6856 0         0 }
6857             }
6858             die qq{Unsupported modifier "$1" used at line $line.\n};
6859 0         0 }
6860              
6861             $slash = 'div';
6862 21 100       30  
    50          
6863 21         62 # literal null string pattern
6864 8         25 if ($string eq '') {
6865 8         13 $modifier =~ tr/bB//d;
6866             $modifier =~ tr/i//d;
6867             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6868             }
6869              
6870 8         60 # with /b /B modifier
6871             elsif ($modifier =~ tr/bB//d) {
6872             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6873             }
6874              
6875 0         0 # without /b /B modifier
6876             else {
6877             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6878             }
6879             }
6880              
6881             #
6882             # escape regexp (s'here'')
6883 13     13 0 32 #
6884             sub e_s1_qt {
6885 13 50       33 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6886              
6887             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6888 13         28  
6889             # split regexp
6890             my @char = $string =~ /\G((?>
6891             [^\\\[\$\@\/] |
6892             [\x00-\xFF] |
6893             \[\^ |
6894             \[\: (?>[a-z]+) \:\] |
6895             \[\:\^ (?>[a-z]+) \:\] |
6896             [\$\@\/] |
6897             \\ (?:$q_char) |
6898             (?:$q_char)
6899             ))/oxmsg;
6900 13         217  
6901 13 50 33     45 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6902             for (my $i=0; $i <= $#char; $i++) {
6903             if (0) {
6904             }
6905 25         114  
6906 0         0 # open character class [...]
6907 0 0       0 elsif ($char[$i] eq '[') {
6908 0         0 my $left = $i;
6909             if ($char[$i+1] eq ']') {
6910 0         0 $i++;
6911 0 0       0 }
6912 0         0 while (1) {
6913             if (++$i > $#char) {
6914 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6915 0         0 }
6916             if ($char[$i] eq ']') {
6917             my $right = $i;
6918 0         0  
6919             # [...]
6920 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6921 0         0  
6922             $i = $left;
6923             last;
6924             }
6925             }
6926             }
6927              
6928 0         0 # open character class [^...]
6929 0 0       0 elsif ($char[$i] eq '[^') {
6930 0         0 my $left = $i;
6931             if ($char[$i+1] eq ']') {
6932 0         0 $i++;
6933 0 0       0 }
6934 0         0 while (1) {
6935             if (++$i > $#char) {
6936 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6937 0         0 }
6938             if ($char[$i] eq ']') {
6939             my $right = $i;
6940 0         0  
6941             # [^...]
6942 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6943 0         0  
6944             $i = $left;
6945             last;
6946             }
6947             }
6948             }
6949              
6950 0         0 # escape $ @ / and \
6951             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6952             $char[$i] = '\\' . $char[$i];
6953             }
6954              
6955 0         0 # rewrite character class or escape character
6956             elsif (my $char = character_class($char[$i],$modifier)) {
6957             $char[$i] = $char;
6958             }
6959              
6960 6 0       14 # /i modifier
6961 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6962             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6963             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6964 0         0 }
6965             else {
6966             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6967             }
6968             }
6969              
6970 0 0       0 # quote character before ? + * {
6971             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6972             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6973 0         0 }
6974             else {
6975             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6976             }
6977             }
6978 0         0 }
6979 13         24  
6980 13         67 $modifier =~ tr/i//d;
6981 13         18 $delimiter = '/';
6982 13         18 $end_delimiter = '/';
6983             my $prematch = '';
6984             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6985             }
6986              
6987             #
6988             # escape regexp (s'here''b)
6989 13     0 0 95 #
6990             sub e_s1_qb {
6991             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6992 0         0  
6993             # split regexp
6994             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6995 0         0  
6996 0 0       0 # unescape character
    0          
6997             for (my $i=0; $i <= $#char; $i++) {
6998             if (0) {
6999             }
7000 0         0  
7001             # remain \\
7002             elsif ($char[$i] eq '\\\\') {
7003             }
7004              
7005 0         0 # escape $ @ / and \
7006             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7007             $char[$i] = '\\' . $char[$i];
7008             }
7009 0         0 }
7010 0         0  
7011 0         0 $delimiter = '/';
7012 0         0 $end_delimiter = '/';
7013             my $prematch = '';
7014             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7015             }
7016              
7017             #
7018             # escape regexp (s''here')
7019 0     16 0 0 #
7020             sub e_s2_q {
7021 16         40 my($ope,$delimiter,$end_delimiter,$string) = @_;
7022              
7023 16         26 $slash = 'div';
7024 16         99  
7025 16 100       53 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7026             for (my $i=0; $i <= $#char; $i++) {
7027             if (0) {
7028             }
7029 9         30  
7030             # not escape \\
7031             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7032             }
7033              
7034 0         0 # escape $ @ / and \
7035             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7036             $char[$i] = '\\' . $char[$i];
7037             }
7038 5         15 }
7039              
7040             return join '', $ope, $delimiter, @char, $end_delimiter;
7041             }
7042              
7043             #
7044             # escape regexp (s/here/and here/modifier)
7045 16     97 0 53 #
7046 97   100     815 sub e_sub {
7047             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7048 97         685 $modifier ||= '';
7049 97 50       191  
7050 97         290 $modifier =~ tr/p//d;
7051 0         0 if ($modifier =~ /([adlu])/oxms) {
7052 0 0       0 my $line = 0;
7053 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7054 0         0 if ($filename ne __FILE__) {
7055             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7056             last;
7057 0         0 }
7058             }
7059             die qq{Unsupported modifier "$1" used at line $line.\n};
7060 0 100       0 }
7061 97         337  
7062 36         44 if ($variable eq '') {
7063             $variable = '$_';
7064             $bind_operator = ' =~ ';
7065 36         56 }
7066              
7067             $slash = 'div';
7068              
7069             # P.128 Start of match (or end of previous match): \G
7070             # P.130 Advanced Use of \G with Perl
7071             # in Chapter 3: Overview of Regular Expression Features and Flavors
7072             # P.312 Iterative Matching: Scalar Context, with /g
7073             # in Chapter 7: Perl
7074             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7075              
7076             # P.181 Where You Left Off: The \G Assertion
7077             # in Chapter 5: Pattern Matching
7078             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7079              
7080             # P.220 Where You Left Off: The \G Assertion
7081             # in Chapter 5: Pattern Matching
7082 97         158 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7083 97         178  
7084             my $e_modifier = $modifier =~ tr/e//d;
7085 97         153 my $r_modifier = $modifier =~ tr/r//d;
7086 97 50       163  
7087 97         292 my $my = '';
7088 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7089 0         0 $my = $variable;
7090             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7091             $variable =~ s/ = .+ \z//oxms;
7092 0         0 }
7093 97         266  
7094             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7095             $variable_basename =~ s/ \s+ \z//oxms;
7096 97         182  
7097 97 100       139 # quote replacement string
7098 97         219 my $e_replacement = '';
7099 17         30 if ($e_modifier >= 1) {
7100             $e_replacement = e_qq('', '', '', $replacement);
7101             $e_modifier--;
7102 17 100       25 }
7103 80         203 else {
7104             if ($delimiter2 eq "'") {
7105             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7106 16         46 }
7107             else {
7108             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7109             }
7110 64         199 }
7111              
7112             my $sub = '';
7113 97 100       236  
7114 97 100       243 # with /r
7115             if ($r_modifier) {
7116             if (0) {
7117             }
7118 8         16  
7119 0 50       0 # s///gr without multibyte anchoring
7120             elsif ($modifier =~ /g/oxms) {
7121             $sub = sprintf(
7122             # 1 2 3 4 5
7123             q,
7124              
7125             $variable, # 1
7126             ($delimiter1 eq "'") ? # 2
7127             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7128             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7129             $s_matched, # 3
7130             $e_replacement, # 4
7131             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
7132             );
7133             }
7134              
7135             # s///r
7136 4         13 else {
7137              
7138 4 50       7 my $prematch = q{$`};
7139              
7140             $sub = sprintf(
7141             # 1 2 3 4 5 6 7
7142             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s"%s$Elatin10::re_r$'" } : %s>,
7143              
7144             $variable, # 1
7145             ($delimiter1 eq "'") ? # 2
7146             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7147             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7148             $s_matched, # 3
7149             $e_replacement, # 4
7150             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
7151             $prematch, # 6
7152             $variable, # 7
7153             );
7154             }
7155 4 50       17  
7156 8         21 # $var !~ s///r doesn't make sense
7157             if ($bind_operator =~ / !~ /oxms) {
7158             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7159             }
7160             }
7161              
7162 0 100       0 # without /r
7163             else {
7164             if (0) {
7165             }
7166 89         288  
7167 0 100       0 # s///g without multibyte anchoring
    100          
7168             elsif ($modifier =~ /g/oxms) {
7169             $sub = sprintf(
7170             # 1 2 3 4 5 6 7 8
7171             q,
7172              
7173             $variable, # 1
7174             ($delimiter1 eq "'") ? # 2
7175             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7176             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7177             $s_matched, # 3
7178             $e_replacement, # 4
7179             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
7180             $variable, # 6
7181             $variable, # 7
7182             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7183             );
7184             }
7185              
7186             # s///
7187 22         87 else {
7188              
7189 67 100       117 my $prematch = q{$`};
    100          
7190              
7191             $sub = sprintf(
7192              
7193             ($bind_operator =~ / =~ /oxms) ?
7194              
7195             # 1 2 3 4 5 6 7 8
7196             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s%s="%s$Elatin10::re_r$'"; 1 } : undef> :
7197              
7198             # 1 2 3 4 5 6 7 8
7199             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s%s="%s$Elatin10::re_r$'"; undef }>,
7200              
7201             $variable, # 1
7202             $bind_operator, # 2
7203             ($delimiter1 eq "'") ? # 3
7204             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7205             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7206             $s_matched, # 4
7207             $e_replacement, # 5
7208             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 6
7209             $variable, # 7
7210             $prematch, # 8
7211             );
7212             }
7213             }
7214 67 50       432  
7215 97         283 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7216             if ($my ne '') {
7217             $sub = "($my, $sub)[1]";
7218             }
7219 0         0  
7220 97         160 # clear s/// variable
7221             $sub_variable = '';
7222 97         131 $bind_operator = '';
7223              
7224             return $sub;
7225             }
7226              
7227             #
7228             # escape regexp of split qr//
7229 97     74 0 670 #
7230 74   100     346 sub e_split {
7231             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7232 74         428 $modifier ||= '';
7233 74 50       148  
7234 74         189 $modifier =~ tr/p//d;
7235 0         0 if ($modifier =~ /([adlu])/oxms) {
7236 0 0       0 my $line = 0;
7237 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7238 0         0 if ($filename ne __FILE__) {
7239             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7240             last;
7241 0         0 }
7242             }
7243             die qq{Unsupported modifier "$1" used at line $line.\n};
7244 0         0 }
7245              
7246             $slash = 'div';
7247 74 50       132  
7248 74         182 # /b /B modifier
7249             if ($modifier =~ tr/bB//d) {
7250             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7251 0 50       0 }
7252 74         177  
7253             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7254             my $metachar = qr/[\@\\|[\]{^]/oxms;
7255 74         258  
7256             # split regexp
7257             my @char = $string =~ /\G((?>
7258             [^\\\$\@\[\(] |
7259             \\x (?>[0-9A-Fa-f]{1,2}) |
7260             \\ (?>[0-7]{2,3}) |
7261             \\c [\x40-\x5F] |
7262             \\x\{ (?>[0-9A-Fa-f]+) \} |
7263             \\o\{ (?>[0-7]+) \} |
7264             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7265             \\ $q_char |
7266             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7267             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7268             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7269             [\$\@] $qq_variable |
7270             \$ (?>\s* [0-9]+) |
7271             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7272             \$ \$ (?![\w\{]) |
7273             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7274             \[\^ |
7275             \[\: (?>[a-z]+) :\] |
7276             \[\:\^ (?>[a-z]+) :\] |
7277             \(\? |
7278             $q_char
7279 74         9240 ))/oxmsg;
7280 74         257  
7281 74         110 my $left_e = 0;
7282             my $right_e = 0;
7283             for (my $i=0; $i <= $#char; $i++) {
7284 74 50 33     356  
    50 33        
    100          
    100          
    50          
    50          
7285 249         1398 # "\L\u" --> "\u\L"
7286             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7287             @char[$i,$i+1] = @char[$i+1,$i];
7288             }
7289              
7290 0         0 # "\U\l" --> "\l\U"
7291             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7292             @char[$i,$i+1] = @char[$i+1,$i];
7293             }
7294              
7295 0         0 # octal escape sequence
7296             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7297             $char[$i] = Elatin10::octchr($1);
7298             }
7299              
7300 1         3 # hexadecimal escape sequence
7301             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7302             $char[$i] = Elatin10::hexchr($1);
7303             }
7304              
7305             # \b{...} --> b\{...}
7306             # \B{...} --> B\{...}
7307             # \N{CHARNAME} --> N\{CHARNAME}
7308             # \p{PROPERTY} --> p\{PROPERTY}
7309 1         3 # \P{PROPERTY} --> P\{PROPERTY}
7310             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7311             $char[$i] = $1 . '\\' . $2;
7312             }
7313              
7314 0         0 # \p, \P, \X --> p, P, X
7315             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7316             $char[$i] = $1;
7317 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          
7318              
7319             if (0) {
7320             }
7321 249         915  
7322 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7323 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7324             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)) {
7325             $char[$i] .= join '', splice @char, $i+1, 3;
7326 0         0 }
7327             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)) {
7328             $char[$i] .= join '', splice @char, $i+1, 2;
7329 0         0 }
7330             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)) {
7331             $char[$i] .= join '', splice @char, $i+1, 1;
7332             }
7333             }
7334              
7335 0         0 # open character class [...]
7336 3 50       6 elsif ($char[$i] eq '[') {
7337 3         10 my $left = $i;
7338             if ($char[$i+1] eq ']') {
7339 0         0 $i++;
7340 3 50       5 }
7341 7         16 while (1) {
7342             if (++$i > $#char) {
7343 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7344 7         11 }
7345             if ($char[$i] eq ']') {
7346             my $right = $i;
7347 3 50       5  
7348 3         17 # [...]
  0         0  
7349             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7350             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);
7351 0         0 }
7352             else {
7353             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7354 3         14 }
7355 3         5  
7356             $i = $left;
7357             last;
7358             }
7359             }
7360             }
7361              
7362 3         9 # open character class [^...]
7363 0 0       0 elsif ($char[$i] eq '[^') {
7364 0         0 my $left = $i;
7365             if ($char[$i+1] eq ']') {
7366 0         0 $i++;
7367 0 0       0 }
7368 0         0 while (1) {
7369             if (++$i > $#char) {
7370 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7371 0         0 }
7372             if ($char[$i] eq ']') {
7373             my $right = $i;
7374 0 0       0  
7375 0         0 # [^...]
  0         0  
7376             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7377             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);
7378 0         0 }
7379             else {
7380             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7381 0         0 }
7382 0         0  
7383             $i = $left;
7384             last;
7385             }
7386             }
7387             }
7388              
7389 0         0 # rewrite character class or escape character
7390             elsif (my $char = character_class($char[$i],$modifier)) {
7391             $char[$i] = $char;
7392             }
7393              
7394             # P.794 29.2.161. split
7395             # in Chapter 29: Functions
7396             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7397              
7398             # P.951 split
7399             # in Chapter 27: Functions
7400             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7401              
7402             # said "The //m modifier is assumed when you split on the pattern /^/",
7403             # but perl5.008 is not so. Therefore, this software adds //m.
7404             # (and so on)
7405              
7406 1         3 # split(m/^/) --> split(m/^/m)
7407             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7408             $modifier .= 'm';
7409             }
7410              
7411 7 0       20 # /i modifier
7412 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7413             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7414             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7415 0         0 }
7416             else {
7417             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7418             }
7419             }
7420              
7421 0 0       0 # \u \l \U \L \F \Q \E
7422 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7423             if ($right_e < $left_e) {
7424             $char[$i] = '\\' . $char[$i];
7425             }
7426 0         0 }
7427 0         0 elsif ($char[$i] eq '\u') {
7428             $char[$i] = '@{[Elatin10::ucfirst qq<';
7429             $left_e++;
7430 0         0 }
7431 0         0 elsif ($char[$i] eq '\l') {
7432             $char[$i] = '@{[Elatin10::lcfirst qq<';
7433             $left_e++;
7434 0         0 }
7435 0         0 elsif ($char[$i] eq '\U') {
7436             $char[$i] = '@{[Elatin10::uc qq<';
7437             $left_e++;
7438 0         0 }
7439 0         0 elsif ($char[$i] eq '\L') {
7440             $char[$i] = '@{[Elatin10::lc qq<';
7441             $left_e++;
7442 0         0 }
7443 0         0 elsif ($char[$i] eq '\F') {
7444             $char[$i] = '@{[Elatin10::fc qq<';
7445             $left_e++;
7446 0         0 }
7447 0         0 elsif ($char[$i] eq '\Q') {
7448             $char[$i] = '@{[CORE::quotemeta qq<';
7449             $left_e++;
7450 0 0       0 }
7451 0         0 elsif ($char[$i] eq '\E') {
7452 0         0 if ($right_e < $left_e) {
7453             $char[$i] = '>]}';
7454             $right_e++;
7455 0         0 }
7456             else {
7457             $char[$i] = '';
7458             }
7459 0         0 }
7460 0 0       0 elsif ($char[$i] eq '\Q') {
7461 0         0 while (1) {
7462             if (++$i > $#char) {
7463 0 0       0 last;
7464 0         0 }
7465             if ($char[$i] eq '\E') {
7466             last;
7467             }
7468             }
7469             }
7470             elsif ($char[$i] eq '\E') {
7471             }
7472              
7473 0 0       0 # $0 --> $0
7474 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7475             if ($ignorecase) {
7476             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7477             }
7478 0 0       0 }
7479 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7480             if ($ignorecase) {
7481             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7482             }
7483             }
7484              
7485             # $$ --> $$
7486             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7487             }
7488              
7489             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7490 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7491 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7492 0         0 $char[$i] = e_capture($1);
7493             if ($ignorecase) {
7494             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7495             }
7496 0         0 }
7497 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7498 0         0 $char[$i] = e_capture($1);
7499             if ($ignorecase) {
7500             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7501             }
7502             }
7503              
7504 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7505 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) {
7506 0         0 $char[$i] = e_capture($1.'->'.$2);
7507             if ($ignorecase) {
7508             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7509             }
7510             }
7511              
7512 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7513 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) {
7514 0         0 $char[$i] = e_capture($1.'->'.$2);
7515             if ($ignorecase) {
7516             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7517             }
7518             }
7519              
7520 0         0 # $$foo
7521 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7522 0         0 $char[$i] = e_capture($1);
7523             if ($ignorecase) {
7524             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7525             }
7526             }
7527              
7528 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
7529 12         35 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7530             if ($ignorecase) {
7531             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
7532 0         0 }
7533             else {
7534             $char[$i] = '@{[Elatin10::PREMATCH()]}';
7535             }
7536             }
7537              
7538 12 50       57 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
7539 12         33 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7540             if ($ignorecase) {
7541             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
7542 0         0 }
7543             else {
7544             $char[$i] = '@{[Elatin10::MATCH()]}';
7545             }
7546             }
7547              
7548 12 50       51 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
7549 9         36 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7550             if ($ignorecase) {
7551             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
7552 0         0 }
7553             else {
7554             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
7555             }
7556             }
7557              
7558 9 0       44 # ${ foo }
7559 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) {
7560             if ($ignorecase) {
7561             $char[$i] = '@{[Elatin10::ignorecase(' . $1 . ')]}';
7562             }
7563             }
7564              
7565 0         0 # ${ ... }
7566 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7567 0         0 $char[$i] = e_capture($1);
7568             if ($ignorecase) {
7569             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7570             }
7571             }
7572              
7573 0         0 # $scalar or @array
7574 3 50       16 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7575 3         13 $char[$i] = e_string($char[$i]);
7576             if ($ignorecase) {
7577             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7578             }
7579             }
7580              
7581 0 50       0 # quote character before ? + * {
7582             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7583             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7584 1         7 }
7585             else {
7586             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7587             }
7588             }
7589             }
7590 0         0  
7591 74 50       211 # make regexp string
7592 74         160 $modifier =~ tr/i//d;
7593             if ($left_e > $right_e) {
7594 0         0 return join '', 'Elatin10::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7595             }
7596             return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7597             }
7598              
7599             #
7600             # escape regexp of split qr''
7601 74     0 0 737 #
7602 0   0       sub e_split_q {
7603             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7604 0           $modifier ||= '';
7605 0 0          
7606 0           $modifier =~ tr/p//d;
7607 0           if ($modifier =~ /([adlu])/oxms) {
7608 0 0         my $line = 0;
7609 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7610 0           if ($filename ne __FILE__) {
7611             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7612             last;
7613 0           }
7614             }
7615             die qq{Unsupported modifier "$1" used at line $line.\n};
7616 0           }
7617              
7618             $slash = 'div';
7619 0 0          
7620 0           # /b /B modifier
7621             if ($modifier =~ tr/bB//d) {
7622             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7623 0 0         }
7624              
7625             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7626 0            
7627             # split regexp
7628             my @char = $string =~ /\G((?>
7629             [^\\\[] |
7630             [\x00-\xFF] |
7631             \[\^ |
7632             \[\: (?>[a-z]+) \:\] |
7633             \[\:\^ (?>[a-z]+) \:\] |
7634             \\ (?:$q_char) |
7635             (?:$q_char)
7636             ))/oxmsg;
7637 0            
7638 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7639             for (my $i=0; $i <= $#char; $i++) {
7640             if (0) {
7641             }
7642 0            
7643 0           # open character class [...]
7644 0 0         elsif ($char[$i] eq '[') {
7645 0           my $left = $i;
7646             if ($char[$i+1] eq ']') {
7647 0           $i++;
7648 0 0         }
7649 0           while (1) {
7650             if (++$i > $#char) {
7651 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7652 0           }
7653             if ($char[$i] eq ']') {
7654             my $right = $i;
7655 0            
7656             # [...]
7657 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7658 0            
7659             $i = $left;
7660             last;
7661             }
7662             }
7663             }
7664              
7665 0           # open character class [^...]
7666 0 0         elsif ($char[$i] eq '[^') {
7667 0           my $left = $i;
7668             if ($char[$i+1] eq ']') {
7669 0           $i++;
7670 0 0         }
7671 0           while (1) {
7672             if (++$i > $#char) {
7673 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7674 0           }
7675             if ($char[$i] eq ']') {
7676             my $right = $i;
7677 0            
7678             # [^...]
7679 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7680 0            
7681             $i = $left;
7682             last;
7683             }
7684             }
7685             }
7686              
7687 0           # rewrite character class or escape character
7688             elsif (my $char = character_class($char[$i],$modifier)) {
7689             $char[$i] = $char;
7690             }
7691              
7692 0           # split(m/^/) --> split(m/^/m)
7693             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7694             $modifier .= 'm';
7695             }
7696              
7697 0 0         # /i modifier
7698 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7699             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7700             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7701 0           }
7702             else {
7703             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7704             }
7705             }
7706              
7707 0 0         # quote character before ? + * {
7708             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7709             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7710 0           }
7711             else {
7712             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7713             }
7714             }
7715 0           }
7716 0            
7717             $modifier =~ tr/i//d;
7718             return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7719             }
7720              
7721             #
7722             # instead of Carp::carp
7723 0     0 0   #
7724 0           sub carp {
7725             my($package,$filename,$line) = caller(1);
7726             print STDERR "@_ at $filename line $line.\n";
7727             }
7728              
7729             #
7730             # instead of Carp::croak
7731 0     0 0   #
7732 0           sub croak {
7733 0           my($package,$filename,$line) = caller(1);
7734             print STDERR "@_ at $filename line $line.\n";
7735             die "\n";
7736             }
7737              
7738             #
7739             # instead of Carp::cluck
7740 0     0 0   #
7741 0           sub cluck {
7742 0           my $i = 0;
7743 0           my @cluck = ();
7744 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7745             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7746 0           $i++;
7747 0           }
7748 0           print STDERR CORE::reverse @cluck;
7749             print STDERR "\n";
7750             print STDERR @_;
7751             }
7752              
7753             #
7754             # instead of Carp::confess
7755 0     0 0   #
7756 0           sub confess {
7757 0           my $i = 0;
7758 0           my @confess = ();
7759 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7760             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7761 0           $i++;
7762 0           }
7763 0           print STDERR CORE::reverse @confess;
7764 0           print STDERR "\n";
7765             print STDERR @_;
7766             die "\n";
7767             }
7768              
7769             1;
7770              
7771             __END__