File Coverage

blib/lib/Elatin10.pm
Criterion Covered Total %
statement 83 3085 2.6
branch 4 2674 0.1
condition 1 373 0.2
subroutine 36 125 28.8
pod 7 74 9.4
total 131 6331 2.0


line stmt bran cond sub pod time code
1             package Elatin10;
2             ######################################################################
3             #
4             # Elatin10 - Run-time routines for Latin10.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin10/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
9             ######################################################################
10              
11 200     200   5099 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         663  
  200         13600  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             # 12.3. Delaying use Until Runtime
15             # in Chapter 12. Packages, Libraries, and Modules
16             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
17             # (and so on)
18              
19             # Version numbers should be boring
20             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
21             # For the impatient, the disinterested or those who just want to follow
22             # a recipe, my advice for all modules is this:
23             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
24             # $VERSION = eval $VERSION;
25              
26 200     200   20637 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1396  
  200         354  
  200         37890  
27             $VERSION = '1.05';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   19406 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         637 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         47458 if (CORE::ord('A') != 0x41) {
38             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
39             }
40             }
41              
42             BEGIN {
43              
44             # instead of utf8.pm
45 200     200   15630 CORE::eval q{
  200     200   1699  
  200     66   376  
  200         35688  
  66         14391  
  61         12943  
  79         14919  
  59         12985  
  62         13271  
  73         13874  
46             no warnings qw(redefine);
47             *utf8::upgrade = sub { CORE::length $_[0] };
48             *utf8::downgrade = sub { 1 };
49             *utf8::encode = sub { };
50             *utf8::decode = sub { 1 };
51             *utf8::is_utf8 = sub { };
52             *utf8::valid = sub { 1 };
53             };
54 200 50       126215 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
  0         0  
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
  0         0  
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65             BEGIN {
66 200     200   533 my $genpkg = "Symbol::";
67 200         10473 my $genseq = 0;
68              
69             sub gensym () {
70 0     0 0 0 my $name = "GEN" . $genseq++;
71              
72             # here, no strict qw(refs); if strict.pm exists
73              
74 0         0 my $ref = \*{$genpkg . $name};
  0         0  
75 0         0 delete $$genpkg{$name};
76 0         0 return $ref;
77             }
78              
79             sub qualify ($;$) {
80 0     0 0 0 my ($name) = @_;
81 0 0 0     0 if (!ref($name) && (Elatin10::index($name, '::') == -1) && (Elatin10::index($name, "'") == -1)) {
      0        
82 0         0 my $pkg;
83 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
84              
85             # Global names: special character, "^xyz", or other.
86 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
89 0         0 $pkg = "main";
90             }
91             else {
92 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
93             }
94 0         0 $name = $pkg . "::" . $name;
95             }
96 0         0 return $name;
97             }
98              
99             sub qualify_to_ref ($;$) {
100              
101             # here, no strict qw(refs); if strict.pm exists
102              
103 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
104             }
105             }
106              
107             # Column: local $@
108             # in Chapter 9. Osaete okitai Perl no kiso
109             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
110             # (and so on)
111              
112             # use strict; if strict.pm exists
113             BEGIN {
114 200 50   200   452 if (CORE::eval { local $@; CORE::require strict }) {
  200         499  
  200         2351  
115 200         29298 strict::->import;
116             }
117             }
118              
119             # P.714 29.2.39. flock
120             # in Chapter 29: Functions
121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
122              
123             # P.863 flock
124             # in Chapter 27: Functions
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126              
127             sub LOCK_SH() {1}
128             sub LOCK_EX() {2}
129             sub LOCK_UN() {8}
130             sub LOCK_NB() {4}
131              
132             # instead of Carp.pm
133             sub carp;
134             sub croak;
135             sub cluck;
136             sub confess;
137              
138             # 6.18. Matching Multiple-Byte Characters
139             # in Chapter 6. Pattern Matching
140             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
141             # (and so on)
142              
143             # regexp of character
144 200     200   16798 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1375  
  200         323  
  200         14186  
145 200     200   14068 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   1172  
  200         296  
  200         14035  
146 200     200   14308 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   1161  
  200         1161  
  200         16718  
147              
148             #
149             # Latin-10 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   17559 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   1178  
  200         500  
  200         513198  
157              
158             #
159             # Latin-10 case conversion
160             #
161             my %lc = ();
162             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
163             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
164             my %uc = ();
165             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
166             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
167             my %fc = ();
168             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
169             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
170              
171             if (0) {
172             }
173              
174             elsif (__PACKAGE__ =~ / \b Elatin10 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-16 | iec[- ]?8859-16 | latin-?10 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA1" => "\xA2", # LATIN LETTER A WITH OGONEK
183             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
184             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
185             "\xAA" => "\xBA", # LATIN LETTER S WITH COMMA BELOW
186             "\xAC" => "\xAE", # LATIN LETTER Z WITH ACUTE
187             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
188             "\xB2" => "\xB9", # LATIN LETTER C WITH CARON
189             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
190             "\xBC" => "\xBD", # LATIN LIGATURE OE
191             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
192             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
193             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
194             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
195             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
196             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
197             "\xC5" => "\xE5", # LATIN LETTER C WITH ACUTE
198             "\xC6" => "\xE6", # LATIN LETTER AE
199             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
200             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
201             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
202             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
203             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
204             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
205             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
206             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
207             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
208             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
209             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
210             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
211             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
212             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
213             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
214             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
215             "\xD7" => "\xF7", # LATIN LETTER S WITH ACUTE
216             "\xD8" => "\xF8", # LATIN LETTER U WITH DOUBLE ACUTE
217             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
218             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
219             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
220             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
221             "\xDD" => "\xFD", # LATIN LETTER E WITH OGONEK
222             "\xDE" => "\xFE", # LATIN LETTER T WITH COMMA BELOW
223             );
224              
225             %uc = (%uc,
226             "\xA2" => "\xA1", # LATIN LETTER A WITH OGONEK
227             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
228             "\xAE" => "\xAC", # LATIN LETTER Z WITH ACUTE
229             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
230             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
231             "\xB9" => "\xB2", # LATIN LETTER C WITH CARON
232             "\xBA" => "\xAA", # LATIN LETTER S WITH COMMA BELOW
233             "\xBD" => "\xBC", # LATIN LIGATURE OE
234             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
235             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
236             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
237             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
238             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
239             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
240             "\xE5" => "\xC5", # LATIN LETTER C WITH ACUTE
241             "\xE6" => "\xC6", # LATIN LETTER AE
242             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
243             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
244             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
245             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
246             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
247             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
248             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
249             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
250             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
251             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
252             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
253             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
254             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
255             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
256             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
257             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
258             "\xF7" => "\xD7", # LATIN LETTER S WITH ACUTE
259             "\xF8" => "\xD8", # LATIN LETTER U WITH DOUBLE ACUTE
260             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
261             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
262             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
263             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
264             "\xFD" => "\xDD", # LATIN LETTER E WITH OGONEK
265             "\xFE" => "\xDE", # LATIN LETTER T WITH COMMA BELOW
266             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
267             );
268              
269             %fc = (%fc,
270             "\xA1" => "\xA2", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
271             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
272             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
273             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH COMMA BELOW --> LATIN SMALL LETTER S WITH COMMA BELOW
274             "\xAC" => "\xAE", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
275             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
276             "\xB2" => "\xB9", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
277             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
278             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
279             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
280             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
281             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
282             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
283             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
284             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
285             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
286             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
287             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
288             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
289             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
290             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
291             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
292             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
293             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
294             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
295             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
296             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
297             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
298             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
299             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
300             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
301             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
302             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
303             "\xD7" => "\xF7", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
304             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
305             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
306             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
307             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
308             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
309             "\xDD" => "\xFD", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
310             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH COMMA BELOW --> LATIN SMALL LETTER T WITH COMMA BELOW
311             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
312             );
313             }
314              
315             else {
316             croak "Don't know my package name '@{[__PACKAGE__]}'";
317             }
318              
319             #
320             # @ARGV wildcard globbing
321             #
322             sub import {
323              
324 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
325 0         0 my @argv = ();
326 0         0 for (@ARGV) {
327              
328             # has space
329 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
330 0 0       0 if (my @glob = Elatin10::glob(qq{"$_"})) {
331 0         0 push @argv, @glob;
332             }
333             else {
334 0         0 push @argv, $_;
335             }
336             }
337              
338             # has wildcard metachar
339             elsif (/\A (?:$q_char)*? [*?] /oxms) {
340 0 0       0 if (my @glob = Elatin10::glob($_)) {
341 0         0 push @argv, @glob;
342             }
343             else {
344 0         0 push @argv, $_;
345             }
346             }
347              
348             # no wildcard globbing
349             else {
350 0         0 push @argv, $_;
351             }
352             }
353 0         0 @ARGV = @argv;
354             }
355              
356 0         0 *Char::ord = \&Latin10::ord;
357 0         0 *Char::ord_ = \&Latin10::ord_;
358 0         0 *Char::reverse = \&Latin10::reverse;
359 0         0 *Char::getc = \&Latin10::getc;
360 0         0 *Char::length = \&Latin10::length;
361 0         0 *Char::substr = \&Latin10::substr;
362 0         0 *Char::index = \&Latin10::index;
363 0         0 *Char::rindex = \&Latin10::rindex;
364 0         0 *Char::eval = \&Latin10::eval;
365 0         0 *Char::escape = \&Latin10::escape;
366 0         0 *Char::escape_token = \&Latin10::escape_token;
367 0         0 *Char::escape_script = \&Latin10::escape_script;
368             }
369              
370             # P.230 Care with Prototypes
371             # in Chapter 6: Subroutines
372             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
373             #
374             # If you aren't careful, you can get yourself into trouble with prototypes.
375             # But if you are careful, you can do a lot of neat things with them. This is
376             # all very powerful, of course, and should only be used in moderation to make
377             # the world a better place.
378              
379             # P.332 Care with Prototypes
380             # in Chapter 7: Subroutines
381             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
382             #
383             # If you aren't careful, you can get yourself into trouble with prototypes.
384             # But if you are careful, you can do a lot of neat things with them. This is
385             # all very powerful, of course, and should only be used in moderation to make
386             # the world a better place.
387              
388             #
389             # Prototypes of subroutines
390             #
391 0     0   0 sub unimport {}
392             sub Elatin10::split(;$$$);
393             sub Elatin10::tr($$$$;$);
394             sub Elatin10::chop(@);
395             sub Elatin10::index($$;$);
396             sub Elatin10::rindex($$;$);
397             sub Elatin10::lcfirst(@);
398             sub Elatin10::lcfirst_();
399             sub Elatin10::lc(@);
400             sub Elatin10::lc_();
401             sub Elatin10::ucfirst(@);
402             sub Elatin10::ucfirst_();
403             sub Elatin10::uc(@);
404             sub Elatin10::uc_();
405             sub Elatin10::fc(@);
406             sub Elatin10::fc_();
407             sub Elatin10::ignorecase;
408             sub Elatin10::classic_character_class;
409             sub Elatin10::capture;
410             sub Elatin10::chr(;$);
411             sub Elatin10::chr_();
412             sub Elatin10::glob($);
413             sub Elatin10::glob_();
414              
415             sub Latin10::ord(;$);
416             sub Latin10::ord_();
417             sub Latin10::reverse(@);
418             sub Latin10::getc(;*@);
419             sub Latin10::length(;$);
420             sub Latin10::substr($$;$$);
421             sub Latin10::index($$;$);
422             sub Latin10::rindex($$;$);
423             sub Latin10::escape(;$);
424              
425             #
426             # Regexp work
427             #
428 200     200   20588 BEGIN { CORE::eval q{ use vars qw(
  200     200   1603  
  200         364  
  200         92555  
429             $Latin10::re_a
430             $Latin10::re_t
431             $Latin10::re_n
432             $Latin10::re_r
433             ) } }
434              
435             #
436             # Character class
437             #
438 200     200   18220 BEGIN { CORE::eval q{ use vars qw(
  200     200   1265  
  200         385  
  200         3635103  
439             $dot
440             $dot_s
441             $eD
442             $eS
443             $eW
444             $eH
445             $eV
446             $eR
447             $eN
448             $not_alnum
449             $not_alpha
450             $not_ascii
451             $not_blank
452             $not_cntrl
453             $not_digit
454             $not_graph
455             $not_lower
456             $not_lower_i
457             $not_print
458             $not_punct
459             $not_space
460             $not_upper
461             $not_upper_i
462             $not_word
463             $not_xdigit
464             $eb
465             $eB
466             ) } }
467              
468             ${Elatin10::dot} = qr{(?>[^\x0A])};
469             ${Elatin10::dot_s} = qr{(?>[\x00-\xFF])};
470             ${Elatin10::eD} = qr{(?>[^0-9])};
471              
472             # Vertical tabs are now whitespace
473             # \s in a regex now matches a vertical tab in all circumstances.
474             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
475             # ${Elatin10::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
476             # ${Elatin10::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
477             ${Elatin10::eS} = qr{(?>[^\s])};
478              
479             ${Elatin10::eW} = qr{(?>[^0-9A-Z_a-z])};
480             ${Elatin10::eH} = qr{(?>[^\x09\x20])};
481             ${Elatin10::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
482             ${Elatin10::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
483             ${Elatin10::eN} = qr{(?>[^\x0A])};
484             ${Elatin10::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
485             ${Elatin10::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
486             ${Elatin10::not_ascii} = qr{(?>[^\x00-\x7F])};
487             ${Elatin10::not_blank} = qr{(?>[^\x09\x20])};
488             ${Elatin10::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
489             ${Elatin10::not_digit} = qr{(?>[^\x30-\x39])};
490             ${Elatin10::not_graph} = qr{(?>[^\x21-\x7F])};
491             ${Elatin10::not_lower} = qr{(?>[^\x61-\x7A])};
492             ${Elatin10::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
493             # ${Elatin10::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
494             ${Elatin10::not_print} = qr{(?>[^\x20-\x7F])};
495             ${Elatin10::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
496             ${Elatin10::not_space} = qr{(?>[^\s\x0B])};
497             ${Elatin10::not_upper} = qr{(?>[^\x41-\x5A])};
498             ${Elatin10::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
499             # ${Elatin10::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
500             ${Elatin10::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
501             ${Elatin10::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
502             ${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))};
503             ${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]))};
504              
505             # avoid: Name "Elatin10::foo" used only once: possible typo at here.
506             ${Elatin10::dot} = ${Elatin10::dot};
507             ${Elatin10::dot_s} = ${Elatin10::dot_s};
508             ${Elatin10::eD} = ${Elatin10::eD};
509             ${Elatin10::eS} = ${Elatin10::eS};
510             ${Elatin10::eW} = ${Elatin10::eW};
511             ${Elatin10::eH} = ${Elatin10::eH};
512             ${Elatin10::eV} = ${Elatin10::eV};
513             ${Elatin10::eR} = ${Elatin10::eR};
514             ${Elatin10::eN} = ${Elatin10::eN};
515             ${Elatin10::not_alnum} = ${Elatin10::not_alnum};
516             ${Elatin10::not_alpha} = ${Elatin10::not_alpha};
517             ${Elatin10::not_ascii} = ${Elatin10::not_ascii};
518             ${Elatin10::not_blank} = ${Elatin10::not_blank};
519             ${Elatin10::not_cntrl} = ${Elatin10::not_cntrl};
520             ${Elatin10::not_digit} = ${Elatin10::not_digit};
521             ${Elatin10::not_graph} = ${Elatin10::not_graph};
522             ${Elatin10::not_lower} = ${Elatin10::not_lower};
523             ${Elatin10::not_lower_i} = ${Elatin10::not_lower_i};
524             ${Elatin10::not_print} = ${Elatin10::not_print};
525             ${Elatin10::not_punct} = ${Elatin10::not_punct};
526             ${Elatin10::not_space} = ${Elatin10::not_space};
527             ${Elatin10::not_upper} = ${Elatin10::not_upper};
528             ${Elatin10::not_upper_i} = ${Elatin10::not_upper_i};
529             ${Elatin10::not_word} = ${Elatin10::not_word};
530             ${Elatin10::not_xdigit} = ${Elatin10::not_xdigit};
531             ${Elatin10::eb} = ${Elatin10::eb};
532             ${Elatin10::eB} = ${Elatin10::eB};
533              
534             #
535             # Latin-10 split
536             #
537             sub Elatin10::split(;$$$) {
538              
539             # P.794 29.2.161. split
540             # in Chapter 29: Functions
541             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
542              
543             # P.951 split
544             # in Chapter 27: Functions
545             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
546              
547 0     0 0 0 my $pattern = $_[0];
548 0         0 my $string = $_[1];
549 0         0 my $limit = $_[2];
550              
551             # if $pattern is also omitted or is the literal space, " "
552 0 0       0 if (not defined $pattern) {
553 0         0 $pattern = ' ';
554             }
555              
556             # if $string is omitted, the function splits the $_ string
557 0 0       0 if (not defined $string) {
558 0 0       0 if (defined $_) {
559 0         0 $string = $_;
560             }
561             else {
562 0         0 $string = '';
563             }
564             }
565              
566 0         0 my @split = ();
567              
568             # when string is empty
569 0 0       0 if ($string eq '') {
    0          
570              
571             # resulting list value in list context
572 0 0       0 if (wantarray) {
573 0         0 return @split;
574             }
575              
576             # count of substrings in scalar context
577             else {
578 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
579 0         0 @_ = @split;
580 0         0 return scalar @_;
581             }
582             }
583              
584             # split's first argument is more consistently interpreted
585             #
586             # After some changes earlier in v5.17, split's behavior has been simplified:
587             # if the PATTERN argument evaluates to a string containing one space, it is
588             # treated the way that a literal string containing one space once was.
589             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
590              
591             # if $pattern is also omitted or is the literal space, " ", the function splits
592             # on whitespace, /\s+/, after skipping any leading whitespace
593             # (and so on)
594              
595             elsif ($pattern eq ' ') {
596 0 0       0 if (not defined $limit) {
597 0         0 return CORE::split(' ', $string);
598             }
599             else {
600 0         0 return CORE::split(' ', $string, $limit);
601             }
602             }
603              
604             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
605 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
606              
607             # a pattern capable of matching either the null string or something longer than the
608             # null string will split the value of $string into separate characters wherever it
609             # matches the null string between characters
610             # (and so on)
611              
612 0 0       0 if ('' =~ / \A $pattern \z /xms) {
613 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
614 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
615              
616             # P.1024 Appendix W.10 Multibyte Processing
617             # of ISBN 1-56592-224-7 CJKV Information Processing
618             # (and so on)
619              
620             # the //m modifier is assumed when you split on the pattern /^/
621             # (and so on)
622              
623             # V
624 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
625              
626             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
627             # is included in the resulting list, interspersed with the fields that are ordinarily returned
628             # (and so on)
629              
630 0         0 local $@;
631 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
632 0         0 push @split, CORE::eval('$' . $digit);
633             }
634             }
635             }
636              
637             else {
638 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
639              
640             # V
641 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
642 0         0 local $@;
643 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
644 0         0 push @split, CORE::eval('$' . $digit);
645             }
646             }
647             }
648             }
649              
650             elsif ($limit > 0) {
651 0 0       0 if ('' =~ / \A $pattern \z /xms) {
652 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
653 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
654              
655             # V
656 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
657 0         0 local $@;
658 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
659 0         0 push @split, CORE::eval('$' . $digit);
660             }
661             }
662             }
663             }
664             else {
665 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
666 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
667              
668             # V
669 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
670 0         0 local $@;
671 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
672 0         0 push @split, CORE::eval('$' . $digit);
673             }
674             }
675             }
676             }
677             }
678              
679 0 0       0 if (CORE::length($string) > 0) {
680 0         0 push @split, $string;
681             }
682              
683             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
684 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
685 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
686 0         0 pop @split;
687             }
688             }
689              
690             # resulting list value in list context
691 0 0       0 if (wantarray) {
692 0         0 return @split;
693             }
694              
695             # count of substrings in scalar context
696             else {
697 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
698 0         0 @_ = @split;
699 0         0 return scalar @_;
700             }
701             }
702              
703             #
704             # get last subexpression offsets
705             #
706             sub _last_subexpression_offsets {
707 0     0   0 my $pattern = $_[0];
708              
709             # remove comment
710 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
711              
712 0         0 my $modifier = '';
713 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
714 0         0 $modifier = $1;
715 0         0 $modifier =~ s/-[A-Za-z]*//;
716             }
717              
718             # with /x modifier
719 0         0 my @char = ();
720 0 0       0 if ($modifier =~ /x/oxms) {
721 0         0 @char = $pattern =~ /\G((?>
722             [^\\\#\[\(] |
723             \\ $q_char |
724             \# (?>[^\n]*) $ |
725             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
726             \(\? |
727             $q_char
728             ))/oxmsg;
729             }
730              
731             # without /x modifier
732             else {
733 0         0 @char = $pattern =~ /\G((?>
734             [^\\\[\(] |
735             \\ $q_char |
736             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
737             \(\? |
738             $q_char
739             ))/oxmsg;
740             }
741              
742 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
743             }
744              
745             #
746             # Latin-10 transliteration (tr///)
747             #
748             sub Elatin10::tr($$$$;$) {
749              
750 0     0 0 0 my $bind_operator = $_[1];
751 0         0 my $searchlist = $_[2];
752 0         0 my $replacementlist = $_[3];
753 0   0     0 my $modifier = $_[4] || '';
754              
755 0 0       0 if ($modifier =~ /r/oxms) {
756 0 0       0 if ($bind_operator =~ / !~ /oxms) {
757 0         0 croak "Using !~ with tr///r doesn't make sense";
758             }
759             }
760              
761 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
762 0         0 my @searchlist = _charlist_tr($searchlist);
763 0         0 my @replacementlist = _charlist_tr($replacementlist);
764              
765 0         0 my %tr = ();
766 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
767 0 0       0 if (not exists $tr{$searchlist[$i]}) {
768 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
769 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
770             }
771             elsif ($modifier =~ /d/oxms) {
772 0         0 $tr{$searchlist[$i]} = '';
773             }
774             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
775 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
776             }
777             else {
778 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
779             }
780             }
781             }
782              
783 0         0 my $tr = 0;
784 0         0 my $replaced = '';
785 0 0       0 if ($modifier =~ /c/oxms) {
786 0         0 while (defined(my $char = shift @char)) {
787 0 0       0 if (not exists $tr{$char}) {
788 0 0       0 if (defined $replacementlist[0]) {
789 0         0 $replaced .= $replacementlist[0];
790             }
791 0         0 $tr++;
792 0 0       0 if ($modifier =~ /s/oxms) {
793 0   0     0 while (@char and (not exists $tr{$char[0]})) {
794 0         0 shift @char;
795 0         0 $tr++;
796             }
797             }
798             }
799             else {
800 0         0 $replaced .= $char;
801             }
802             }
803             }
804             else {
805 0         0 while (defined(my $char = shift @char)) {
806 0 0       0 if (exists $tr{$char}) {
807 0         0 $replaced .= $tr{$char};
808 0         0 $tr++;
809 0 0       0 if ($modifier =~ /s/oxms) {
810 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
811 0         0 shift @char;
812 0         0 $tr++;
813             }
814             }
815             }
816             else {
817 0         0 $replaced .= $char;
818             }
819             }
820             }
821              
822 0 0       0 if ($modifier =~ /r/oxms) {
823 0         0 return $replaced;
824             }
825             else {
826 0         0 $_[0] = $replaced;
827 0 0       0 if ($bind_operator =~ / !~ /oxms) {
828 0         0 return not $tr;
829             }
830             else {
831 0         0 return $tr;
832             }
833             }
834             }
835              
836             #
837             # Latin-10 chop
838             #
839             sub Elatin10::chop(@) {
840              
841 0     0 0 0 my $chop;
842 0 0       0 if (@_ == 0) {
843 0         0 my @char = /\G (?>$q_char) /oxmsg;
844 0         0 $chop = pop @char;
845 0         0 $_ = join '', @char;
846             }
847             else {
848 0         0 for (@_) {
849 0         0 my @char = /\G (?>$q_char) /oxmsg;
850 0         0 $chop = pop @char;
851 0         0 $_ = join '', @char;
852             }
853             }
854 0         0 return $chop;
855             }
856              
857             #
858             # Latin-10 index by octet
859             #
860             sub Elatin10::index($$;$) {
861              
862 0     0 1 0 my($str,$substr,$position) = @_;
863 0   0     0 $position ||= 0;
864 0         0 my $pos = 0;
865              
866 0         0 while ($pos < CORE::length($str)) {
867 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
868 0 0       0 if ($pos >= $position) {
869 0         0 return $pos;
870             }
871             }
872 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
873 0         0 $pos += CORE::length($1);
874             }
875             else {
876 0         0 $pos += 1;
877             }
878             }
879 0         0 return -1;
880             }
881              
882             #
883             # Latin-10 reverse index
884             #
885             sub Elatin10::rindex($$;$) {
886              
887 0     0 0 0 my($str,$substr,$position) = @_;
888 0   0     0 $position ||= CORE::length($str) - 1;
889 0         0 my $pos = 0;
890 0         0 my $rindex = -1;
891              
892 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
893 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
894 0         0 $rindex = $pos;
895             }
896 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
897 0         0 $pos += CORE::length($1);
898             }
899             else {
900 0         0 $pos += 1;
901             }
902             }
903 0         0 return $rindex;
904             }
905              
906             #
907             # Latin-10 lower case first with parameter
908             #
909             sub Elatin10::lcfirst(@) {
910 0 0   0 0 0 if (@_) {
911 0         0 my $s = shift @_;
912 0 0 0     0 if (@_ and wantarray) {
913 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
914             }
915             else {
916 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
917             }
918             }
919             else {
920 0         0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
921             }
922             }
923              
924             #
925             # Latin-10 lower case first without parameter
926             #
927             sub Elatin10::lcfirst_() {
928 0     0 0 0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
929             }
930              
931             #
932             # Latin-10 lower case with parameter
933             #
934             sub Elatin10::lc(@) {
935 0 0   0 0 0 if (@_) {
936 0         0 my $s = shift @_;
937 0 0 0     0 if (@_ and wantarray) {
938 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
939             }
940             else {
941 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
942             }
943             }
944             else {
945 0         0 return Elatin10::lc_();
946             }
947             }
948              
949             #
950             # Latin-10 lower case without parameter
951             #
952             sub Elatin10::lc_() {
953 0     0 0 0 my $s = $_;
954 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
955             }
956              
957             #
958             # Latin-10 upper case first with parameter
959             #
960             sub Elatin10::ucfirst(@) {
961 0 0   0 0 0 if (@_) {
962 0         0 my $s = shift @_;
963 0 0 0     0 if (@_ and wantarray) {
964 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
965             }
966             else {
967 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
968             }
969             }
970             else {
971 0         0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
972             }
973             }
974              
975             #
976             # Latin-10 upper case first without parameter
977             #
978             sub Elatin10::ucfirst_() {
979 0     0 0 0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
980             }
981              
982             #
983             # Latin-10 upper case with parameter
984             #
985             sub Elatin10::uc(@) {
986 0 0   0 0 0 if (@_) {
987 0         0 my $s = shift @_;
988 0 0 0     0 if (@_ and wantarray) {
989 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
990             }
991             else {
992 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
993             }
994             }
995             else {
996 0         0 return Elatin10::uc_();
997             }
998             }
999              
1000             #
1001             # Latin-10 upper case without parameter
1002             #
1003             sub Elatin10::uc_() {
1004 0     0 0 0 my $s = $_;
1005 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1006             }
1007              
1008             #
1009             # Latin-10 fold case with parameter
1010             #
1011             sub Elatin10::fc(@) {
1012 0 0   0 0 0 if (@_) {
1013 0         0 my $s = shift @_;
1014 0 0 0     0 if (@_ and wantarray) {
1015 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1016             }
1017             else {
1018 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1019             }
1020             }
1021             else {
1022 0         0 return Elatin10::fc_();
1023             }
1024             }
1025              
1026             #
1027             # Latin-10 fold case without parameter
1028             #
1029             sub Elatin10::fc_() {
1030 0     0 0 0 my $s = $_;
1031 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1032             }
1033              
1034             #
1035             # Latin-10 regexp capture
1036             #
1037             {
1038             sub Elatin10::capture {
1039 0     0 1 0 return $_[0];
1040             }
1041             }
1042              
1043             #
1044             # Latin-10 regexp ignore case modifier
1045             #
1046             sub Elatin10::ignorecase {
1047              
1048 0     0 0 0 my @string = @_;
1049 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1050              
1051             # ignore case of $scalar or @array
1052 0         0 for my $string (@string) {
1053              
1054             # split regexp
1055 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1056              
1057             # unescape character
1058 0         0 for (my $i=0; $i <= $#char; $i++) {
1059 0 0       0 next if not defined $char[$i];
1060              
1061             # open character class [...]
1062 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1063 0         0 my $left = $i;
1064              
1065             # [] make die "unmatched [] in regexp ...\n"
1066              
1067 0 0       0 if ($char[$i+1] eq ']') {
1068 0         0 $i++;
1069             }
1070              
1071 0         0 while (1) {
1072 0 0       0 if (++$i > $#char) {
1073 0         0 croak "Unmatched [] in regexp";
1074             }
1075 0 0       0 if ($char[$i] eq ']') {
1076 0         0 my $right = $i;
1077 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1078              
1079             # escape character
1080 0         0 for my $char (@charlist) {
1081 0 0       0 if (0) {
1082             }
1083              
1084 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1085 0         0 $char = '\\' . $char;
1086             }
1087             }
1088              
1089             # [...]
1090 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1091              
1092 0         0 $i = $left;
1093 0         0 last;
1094             }
1095             }
1096             }
1097              
1098             # open character class [^...]
1099             elsif ($char[$i] eq '[^') {
1100 0         0 my $left = $i;
1101              
1102             # [^] make die "unmatched [] in regexp ...\n"
1103              
1104 0 0       0 if ($char[$i+1] eq ']') {
1105 0         0 $i++;
1106             }
1107              
1108 0         0 while (1) {
1109 0 0       0 if (++$i > $#char) {
1110 0         0 croak "Unmatched [] in regexp";
1111             }
1112 0 0       0 if ($char[$i] eq ']') {
1113 0         0 my $right = $i;
1114 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1115              
1116             # escape character
1117 0         0 for my $char (@charlist) {
1118 0 0       0 if (0) {
1119             }
1120              
1121 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1122 0         0 $char = '\\' . $char;
1123             }
1124             }
1125              
1126             # [^...]
1127 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1128              
1129 0         0 $i = $left;
1130 0         0 last;
1131             }
1132             }
1133             }
1134              
1135             # rewrite classic character class or escape character
1136             elsif (my $char = classic_character_class($char[$i])) {
1137 0         0 $char[$i] = $char;
1138             }
1139              
1140             # with /i modifier
1141             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1142 0         0 my $uc = Elatin10::uc($char[$i]);
1143 0         0 my $fc = Elatin10::fc($char[$i]);
1144 0 0       0 if ($uc ne $fc) {
1145 0 0       0 if (CORE::length($fc) == 1) {
1146 0         0 $char[$i] = '[' . $uc . $fc . ']';
1147             }
1148             else {
1149 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1150             }
1151             }
1152             }
1153             }
1154              
1155             # characterize
1156 0         0 for (my $i=0; $i <= $#char; $i++) {
1157 0 0       0 next if not defined $char[$i];
1158              
1159 0 0       0 if (0) {
1160             }
1161              
1162             # quote character before ? + * {
1163 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1164 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1165 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1166             }
1167             }
1168             }
1169              
1170 0         0 $string = join '', @char;
1171             }
1172              
1173             # make regexp string
1174 0         0 return @string;
1175             }
1176              
1177             #
1178             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1179             #
1180             sub Elatin10::classic_character_class {
1181 0     0 0 0 my($char) = @_;
1182              
1183             return {
1184 0   0     0 '\D' => '${Elatin10::eD}',
1185             '\S' => '${Elatin10::eS}',
1186             '\W' => '${Elatin10::eW}',
1187             '\d' => '[0-9]',
1188              
1189             # Before Perl 5.6, \s only matched the five whitespace characters
1190             # tab, newline, form-feed, carriage return, and the space character
1191             # itself, which, taken together, is the character class [\t\n\f\r ].
1192              
1193             # Vertical tabs are now whitespace
1194             # \s in a regex now matches a vertical tab in all circumstances.
1195             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1196             # \t \n \v \f \r space
1197             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1198             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1199             '\s' => '\s',
1200              
1201             '\w' => '[0-9A-Z_a-z]',
1202             '\C' => '[\x00-\xFF]',
1203             '\X' => 'X',
1204              
1205             # \h \v \H \V
1206              
1207             # P.114 Character Class Shortcuts
1208             # in Chapter 7: In the World of Regular Expressions
1209             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1210              
1211             # P.357 13.2.3 Whitespace
1212             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1213             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1214             #
1215             # 0x00009 CHARACTER TABULATION h s
1216             # 0x0000a LINE FEED (LF) vs
1217             # 0x0000b LINE TABULATION v
1218             # 0x0000c FORM FEED (FF) vs
1219             # 0x0000d CARRIAGE RETURN (CR) vs
1220             # 0x00020 SPACE h s
1221              
1222             # P.196 Table 5-9. Alphanumeric regex metasymbols
1223             # in Chapter 5. Pattern Matching
1224             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1225              
1226             # (and so on)
1227              
1228             '\H' => '${Elatin10::eH}',
1229             '\V' => '${Elatin10::eV}',
1230             '\h' => '[\x09\x20]',
1231             '\v' => '[\x0A\x0B\x0C\x0D]',
1232             '\R' => '${Elatin10::eR}',
1233              
1234             # \N
1235             #
1236             # http://perldoc.perl.org/perlre.html
1237             # Character Classes and other Special Escapes
1238             # Any character but \n (experimental). Not affected by /s modifier
1239              
1240             '\N' => '${Elatin10::eN}',
1241              
1242             # \b \B
1243              
1244             # P.180 Boundaries: The \b and \B Assertions
1245             # in Chapter 5: Pattern Matching
1246             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1247              
1248             # P.219 Boundaries: The \b and \B Assertions
1249             # in Chapter 5: Pattern Matching
1250             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1251              
1252             # \b really means (?:(?<=\w)(?!\w)|(?
1253             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1254             '\b' => '${Elatin10::eb}',
1255              
1256             # \B really means (?:(?<=\w)(?=\w)|(?
1257             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1258             '\B' => '${Elatin10::eB}',
1259              
1260             }->{$char} || '';
1261             }
1262              
1263             #
1264             # prepare Latin-10 characters per length
1265             #
1266              
1267             # 1 octet characters
1268             my @chars1 = ();
1269             sub chars1 {
1270 0 0   0 0 0 if (@chars1) {
1271 0         0 return @chars1;
1272             }
1273 0 0       0 if (exists $range_tr{1}) {
1274 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1275 0         0 while (my @range = splice(@ranges,0,1)) {
1276 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1277 0         0 push @chars1, pack 'C', $oct0;
1278             }
1279             }
1280             }
1281 0         0 return @chars1;
1282             }
1283              
1284             # 2 octets characters
1285             my @chars2 = ();
1286             sub chars2 {
1287 0 0   0 0 0 if (@chars2) {
1288 0         0 return @chars2;
1289             }
1290 0 0       0 if (exists $range_tr{2}) {
1291 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1292 0         0 while (my @range = splice(@ranges,0,2)) {
1293 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1294 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1295 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1296             }
1297             }
1298             }
1299             }
1300 0         0 return @chars2;
1301             }
1302              
1303             # 3 octets characters
1304             my @chars3 = ();
1305             sub chars3 {
1306 0 0   0 0 0 if (@chars3) {
1307 0         0 return @chars3;
1308             }
1309 0 0       0 if (exists $range_tr{3}) {
1310 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1311 0         0 while (my @range = splice(@ranges,0,3)) {
1312 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1313 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1314 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1315 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1316             }
1317             }
1318             }
1319             }
1320             }
1321 0         0 return @chars3;
1322             }
1323              
1324             # 4 octets characters
1325             my @chars4 = ();
1326             sub chars4 {
1327 0 0   0 0 0 if (@chars4) {
1328 0         0 return @chars4;
1329             }
1330 0 0       0 if (exists $range_tr{4}) {
1331 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1332 0         0 while (my @range = splice(@ranges,0,4)) {
1333 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1334 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1335 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1336 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1337 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1338             }
1339             }
1340             }
1341             }
1342             }
1343             }
1344 0         0 return @chars4;
1345             }
1346              
1347             #
1348             # Latin-10 open character list for tr
1349             #
1350             sub _charlist_tr {
1351              
1352 0     0   0 local $_ = shift @_;
1353              
1354             # unescape character
1355 0         0 my @char = ();
1356 0         0 while (not /\G \z/oxmsgc) {
1357 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1358 0         0 push @char, '\-';
1359             }
1360             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1361 0         0 push @char, CORE::chr(oct $1);
1362             }
1363             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1364 0         0 push @char, CORE::chr(hex $1);
1365             }
1366             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1367 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1368             }
1369             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1370 0         0 push @char, {
1371             '\0' => "\0",
1372             '\n' => "\n",
1373             '\r' => "\r",
1374             '\t' => "\t",
1375             '\f' => "\f",
1376             '\b' => "\x08", # \b means backspace in character class
1377             '\a' => "\a",
1378             '\e' => "\e",
1379             }->{$1};
1380             }
1381             elsif (/\G \\ ($q_char) /oxmsgc) {
1382 0         0 push @char, $1;
1383             }
1384             elsif (/\G ($q_char) /oxmsgc) {
1385 0         0 push @char, $1;
1386             }
1387             }
1388              
1389             # join separated multiple-octet
1390 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1391              
1392             # unescape '-'
1393 0         0 my @i = ();
1394 0         0 for my $i (0 .. $#char) {
1395 0 0       0 if ($char[$i] eq '\-') {
    0          
1396 0         0 $char[$i] = '-';
1397             }
1398             elsif ($char[$i] eq '-') {
1399 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1400 0         0 push @i, $i;
1401             }
1402             }
1403             }
1404              
1405             # open character list (reverse for splice)
1406 0         0 for my $i (CORE::reverse @i) {
1407 0         0 my @range = ();
1408              
1409             # range error
1410 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1411 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1412             }
1413              
1414             # range of multiple-octet code
1415 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1416 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1417 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1418             }
1419             elsif (CORE::length($char[$i+1]) == 2) {
1420 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1421 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1422             }
1423             elsif (CORE::length($char[$i+1]) == 3) {
1424 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1425 0         0 push @range, chars2();
1426 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1427             }
1428             elsif (CORE::length($char[$i+1]) == 4) {
1429 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1430 0         0 push @range, chars2();
1431 0         0 push @range, chars3();
1432 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1433             }
1434             else {
1435 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1436             }
1437             }
1438             elsif (CORE::length($char[$i-1]) == 2) {
1439 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1440 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1441             }
1442             elsif (CORE::length($char[$i+1]) == 3) {
1443 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1444 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1445             }
1446             elsif (CORE::length($char[$i+1]) == 4) {
1447 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1448 0         0 push @range, chars3();
1449 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1450             }
1451             else {
1452 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1453             }
1454             }
1455             elsif (CORE::length($char[$i-1]) == 3) {
1456 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1457 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1458             }
1459             elsif (CORE::length($char[$i+1]) == 4) {
1460 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1461 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1462             }
1463             else {
1464 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1465             }
1466             }
1467             elsif (CORE::length($char[$i-1]) == 4) {
1468 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1469 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1470             }
1471             else {
1472 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1473             }
1474             }
1475             else {
1476 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1477             }
1478              
1479 0         0 splice @char, $i-1, 3, @range;
1480             }
1481              
1482 0         0 return @char;
1483             }
1484              
1485             #
1486             # Latin-10 open character class
1487             #
1488             sub _cc {
1489 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1490 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1491             }
1492             elsif (scalar(@_) == 1) {
1493 0         0 return sprintf('\x%02X',$_[0]);
1494             }
1495             elsif (scalar(@_) == 2) {
1496 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1497 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1498             }
1499             elsif ($_[0] == $_[1]) {
1500 0         0 return sprintf('\x%02X',$_[0]);
1501             }
1502             elsif (($_[0]+1) == $_[1]) {
1503 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1504             }
1505             else {
1506 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1507             }
1508             }
1509             else {
1510 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1511             }
1512             }
1513              
1514             #
1515             # Latin-10 octet range
1516             #
1517             sub _octets {
1518 0     0   0 my $length = shift @_;
1519              
1520 0 0       0 if ($length == 1) {
1521 0         0 my($a1) = unpack 'C', $_[0];
1522 0         0 my($z1) = unpack 'C', $_[1];
1523              
1524 0 0       0 if ($a1 > $z1) {
1525 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1526             }
1527              
1528 0 0       0 if ($a1 == $z1) {
    0          
1529 0         0 return sprintf('\x%02X',$a1);
1530             }
1531             elsif (($a1+1) == $z1) {
1532 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1533             }
1534             else {
1535 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1536             }
1537             }
1538             else {
1539 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1540             }
1541             }
1542              
1543             #
1544             # Latin-10 range regexp
1545             #
1546             sub _range_regexp {
1547 0     0   0 my($length,$first,$last) = @_;
1548              
1549 0         0 my @range_regexp = ();
1550 0 0       0 if (not exists $range_tr{$length}) {
1551 0         0 return @range_regexp;
1552             }
1553              
1554 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1555 0         0 while (my @range = splice(@ranges,0,$length)) {
1556 0         0 my $min = '';
1557 0         0 my $max = '';
1558 0         0 for (my $i=0; $i < $length; $i++) {
1559 0         0 $min .= pack 'C', $range[$i][0];
1560 0         0 $max .= pack 'C', $range[$i][-1];
1561             }
1562              
1563             # min___max
1564             # FIRST_____________LAST
1565             # (nothing)
1566              
1567 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1568             }
1569              
1570             # **********
1571             # min_________max
1572             # FIRST_____________LAST
1573             # **********
1574              
1575             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1576 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1577             }
1578              
1579             # **********************
1580             # min________________max
1581             # FIRST_____________LAST
1582             # **********************
1583              
1584             elsif (($min eq $first) and ($max eq $last)) {
1585 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1586             }
1587              
1588             # *********
1589             # min___max
1590             # FIRST_____________LAST
1591             # *********
1592              
1593             elsif (($first le $min) and ($max le $last)) {
1594 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1595             }
1596              
1597             # **********************
1598             # min__________________________max
1599             # FIRST_____________LAST
1600             # **********************
1601              
1602             elsif (($min le $first) and ($last le $max)) {
1603 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1604             }
1605              
1606             # *********
1607             # min________max
1608             # FIRST_____________LAST
1609             # *********
1610              
1611             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1612 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1613             }
1614              
1615             # min___max
1616             # FIRST_____________LAST
1617             # (nothing)
1618              
1619             elsif ($last lt $min) {
1620             }
1621              
1622             else {
1623 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1624             }
1625             }
1626              
1627 0         0 return @range_regexp;
1628             }
1629              
1630             #
1631             # Latin-10 open character list for qr and not qr
1632             #
1633             sub _charlist {
1634              
1635 0     0   0 my $modifier = pop @_;
1636 0         0 my @char = @_;
1637              
1638 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1639              
1640             # unescape character
1641 0         0 for (my $i=0; $i <= $#char; $i++) {
1642              
1643             # escape - to ...
1644 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1645 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1646 0         0 $char[$i] = '...';
1647             }
1648             }
1649              
1650             # octal escape sequence
1651             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1652 0         0 $char[$i] = octchr($1);
1653             }
1654              
1655             # hexadecimal escape sequence
1656             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1657 0         0 $char[$i] = hexchr($1);
1658             }
1659              
1660             # \b{...} --> b\{...}
1661             # \B{...} --> B\{...}
1662             # \N{CHARNAME} --> N\{CHARNAME}
1663             # \p{PROPERTY} --> p\{PROPERTY}
1664             # \P{PROPERTY} --> P\{PROPERTY}
1665             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1666 0         0 $char[$i] = $1 . '\\' . $2;
1667             }
1668              
1669             # \p, \P, \X --> p, P, X
1670             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1671 0         0 $char[$i] = $1;
1672             }
1673              
1674             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1675 0         0 $char[$i] = CORE::chr oct $1;
1676             }
1677             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1678 0         0 $char[$i] = CORE::chr hex $1;
1679             }
1680             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1681 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1682             }
1683             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1684 0         0 $char[$i] = {
1685             '\0' => "\0",
1686             '\n' => "\n",
1687             '\r' => "\r",
1688             '\t' => "\t",
1689             '\f' => "\f",
1690             '\b' => "\x08", # \b means backspace in character class
1691             '\a' => "\a",
1692             '\e' => "\e",
1693             '\d' => '[0-9]',
1694              
1695             # Vertical tabs are now whitespace
1696             # \s in a regex now matches a vertical tab in all circumstances.
1697             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1698             # \t \n \v \f \r space
1699             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1700             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1701             '\s' => '\s',
1702              
1703             '\w' => '[0-9A-Z_a-z]',
1704             '\D' => '${Elatin10::eD}',
1705             '\S' => '${Elatin10::eS}',
1706             '\W' => '${Elatin10::eW}',
1707              
1708             '\H' => '${Elatin10::eH}',
1709             '\V' => '${Elatin10::eV}',
1710             '\h' => '[\x09\x20]',
1711             '\v' => '[\x0A\x0B\x0C\x0D]',
1712             '\R' => '${Elatin10::eR}',
1713              
1714             }->{$1};
1715             }
1716              
1717             # POSIX-style character classes
1718             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1719 0         0 $char[$i] = {
1720              
1721             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1722             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1723             '[:^lower:]' => '${Elatin10::not_lower_i}',
1724             '[:^upper:]' => '${Elatin10::not_upper_i}',
1725              
1726             }->{$1};
1727             }
1728             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1729 0         0 $char[$i] = {
1730              
1731             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1732             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1733             '[:ascii:]' => '[\x00-\x7F]',
1734             '[:blank:]' => '[\x09\x20]',
1735             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1736             '[:digit:]' => '[\x30-\x39]',
1737             '[:graph:]' => '[\x21-\x7F]',
1738             '[:lower:]' => '[\x61-\x7A]',
1739             '[:print:]' => '[\x20-\x7F]',
1740             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1741              
1742             # P.174 POSIX-Style Character Classes
1743             # in Chapter 5: Pattern Matching
1744             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1745              
1746             # P.311 11.2.4 Character Classes and other Special Escapes
1747             # in Chapter 11: perlre: Perl regular expressions
1748             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1749              
1750             # P.210 POSIX-Style Character Classes
1751             # in Chapter 5: Pattern Matching
1752             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1753              
1754             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1755              
1756             '[:upper:]' => '[\x41-\x5A]',
1757             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1758             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1759             '[:^alnum:]' => '${Elatin10::not_alnum}',
1760             '[:^alpha:]' => '${Elatin10::not_alpha}',
1761             '[:^ascii:]' => '${Elatin10::not_ascii}',
1762             '[:^blank:]' => '${Elatin10::not_blank}',
1763             '[:^cntrl:]' => '${Elatin10::not_cntrl}',
1764             '[:^digit:]' => '${Elatin10::not_digit}',
1765             '[:^graph:]' => '${Elatin10::not_graph}',
1766             '[:^lower:]' => '${Elatin10::not_lower}',
1767             '[:^print:]' => '${Elatin10::not_print}',
1768             '[:^punct:]' => '${Elatin10::not_punct}',
1769             '[:^space:]' => '${Elatin10::not_space}',
1770             '[:^upper:]' => '${Elatin10::not_upper}',
1771             '[:^word:]' => '${Elatin10::not_word}',
1772             '[:^xdigit:]' => '${Elatin10::not_xdigit}',
1773              
1774             }->{$1};
1775             }
1776             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1777 0         0 $char[$i] = $1;
1778             }
1779             }
1780              
1781             # open character list
1782 0         0 my @singleoctet = ();
1783 0         0 my @multipleoctet = ();
1784 0         0 for (my $i=0; $i <= $#char; ) {
1785              
1786             # escaped -
1787 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1788 0         0 $i += 1;
1789 0         0 next;
1790             }
1791              
1792             # make range regexp
1793             elsif ($char[$i] eq '...') {
1794              
1795             # range error
1796 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1797 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1798             }
1799             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1800 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1801 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1802             }
1803             }
1804              
1805             # make range regexp per length
1806 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1807 0         0 my @regexp = ();
1808              
1809             # is first and last
1810 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1811 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1812             }
1813              
1814             # is first
1815             elsif ($length == CORE::length($char[$i-1])) {
1816 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1817             }
1818              
1819             # is inside in first and last
1820             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1821 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1822             }
1823              
1824             # is last
1825             elsif ($length == CORE::length($char[$i+1])) {
1826 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1827             }
1828              
1829             else {
1830 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1831             }
1832              
1833 0 0       0 if ($length == 1) {
1834 0         0 push @singleoctet, @regexp;
1835             }
1836             else {
1837 0         0 push @multipleoctet, @regexp;
1838             }
1839             }
1840              
1841 0         0 $i += 2;
1842             }
1843              
1844             # with /i modifier
1845             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1846 0 0       0 if ($modifier =~ /i/oxms) {
1847 0         0 my $uc = Elatin10::uc($char[$i]);
1848 0         0 my $fc = Elatin10::fc($char[$i]);
1849 0 0       0 if ($uc ne $fc) {
1850 0 0       0 if (CORE::length($fc) == 1) {
1851 0         0 push @singleoctet, $uc, $fc;
1852             }
1853             else {
1854 0         0 push @singleoctet, $uc;
1855 0         0 push @multipleoctet, $fc;
1856             }
1857             }
1858             else {
1859 0         0 push @singleoctet, $char[$i];
1860             }
1861             }
1862             else {
1863 0         0 push @singleoctet, $char[$i];
1864             }
1865 0         0 $i += 1;
1866             }
1867              
1868             # single character of single octet code
1869             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1870 0         0 push @singleoctet, "\t", "\x20";
1871 0         0 $i += 1;
1872             }
1873             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1874 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1875 0         0 $i += 1;
1876             }
1877             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1878 0         0 push @singleoctet, $char[$i];
1879 0         0 $i += 1;
1880             }
1881              
1882             # single character of multiple-octet code
1883             else {
1884 0         0 push @multipleoctet, $char[$i];
1885 0         0 $i += 1;
1886             }
1887             }
1888              
1889             # quote metachar
1890 0         0 for (@singleoctet) {
1891 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1892 0         0 $_ = '-';
1893             }
1894             elsif (/\A \n \z/oxms) {
1895 0         0 $_ = '\n';
1896             }
1897             elsif (/\A \r \z/oxms) {
1898 0         0 $_ = '\r';
1899             }
1900             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1901 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1902             }
1903             elsif (/\A [\x00-\xFF] \z/oxms) {
1904 0         0 $_ = quotemeta $_;
1905             }
1906             }
1907              
1908             # return character list
1909 0         0 return \@singleoctet, \@multipleoctet;
1910             }
1911              
1912             #
1913             # Latin-10 octal escape sequence
1914             #
1915             sub octchr {
1916 0     0 0 0 my($octdigit) = @_;
1917              
1918 0         0 my @binary = ();
1919 0         0 for my $octal (split(//,$octdigit)) {
1920 0         0 push @binary, {
1921             '0' => '000',
1922             '1' => '001',
1923             '2' => '010',
1924             '3' => '011',
1925             '4' => '100',
1926             '5' => '101',
1927             '6' => '110',
1928             '7' => '111',
1929             }->{$octal};
1930             }
1931 0         0 my $binary = join '', @binary;
1932              
1933 0         0 my $octchr = {
1934             # 1234567
1935             1 => pack('B*', "0000000$binary"),
1936             2 => pack('B*', "000000$binary"),
1937             3 => pack('B*', "00000$binary"),
1938             4 => pack('B*', "0000$binary"),
1939             5 => pack('B*', "000$binary"),
1940             6 => pack('B*', "00$binary"),
1941             7 => pack('B*', "0$binary"),
1942             0 => pack('B*', "$binary"),
1943              
1944             }->{CORE::length($binary) % 8};
1945              
1946 0         0 return $octchr;
1947             }
1948              
1949             #
1950             # Latin-10 hexadecimal escape sequence
1951             #
1952             sub hexchr {
1953 0     0 0 0 my($hexdigit) = @_;
1954              
1955 0         0 my $hexchr = {
1956             1 => pack('H*', "0$hexdigit"),
1957             0 => pack('H*', "$hexdigit"),
1958              
1959             }->{CORE::length($_[0]) % 2};
1960              
1961 0         0 return $hexchr;
1962             }
1963              
1964             #
1965             # Latin-10 open character list for qr
1966             #
1967             sub charlist_qr {
1968              
1969 0     0 0 0 my $modifier = pop @_;
1970 0         0 my @char = @_;
1971              
1972 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1973 0         0 my @singleoctet = @$singleoctet;
1974 0         0 my @multipleoctet = @$multipleoctet;
1975              
1976             # return character list
1977 0 0       0 if (scalar(@singleoctet) >= 1) {
1978              
1979             # with /i modifier
1980 0 0       0 if ($modifier =~ m/i/oxms) {
1981 0         0 my %singleoctet_ignorecase = ();
1982 0         0 for (@singleoctet) {
1983 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1984 0         0 for my $ord (hex($1) .. hex($2)) {
1985 0         0 my $char = CORE::chr($ord);
1986 0         0 my $uc = Elatin10::uc($char);
1987 0         0 my $fc = Elatin10::fc($char);
1988 0 0       0 if ($uc eq $fc) {
1989 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1990             }
1991             else {
1992 0 0       0 if (CORE::length($fc) == 1) {
1993 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1994 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1995             }
1996             else {
1997 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1998 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1999             }
2000             }
2001             }
2002             }
2003 0 0       0 if ($_ ne '') {
2004 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2005             }
2006             }
2007 0         0 my $i = 0;
2008 0         0 my @singleoctet_ignorecase = ();
2009 0         0 for my $ord (0 .. 255) {
2010 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2011 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2012             }
2013             else {
2014 0         0 $i++;
2015             }
2016             }
2017 0         0 @singleoctet = ();
2018 0         0 for my $range (@singleoctet_ignorecase) {
2019 0 0       0 if (ref $range) {
2020 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2021 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2022             }
2023             elsif (scalar(@{$range}) == 2) {
2024 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2025             }
2026             else {
2027 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2028             }
2029             }
2030             }
2031             }
2032              
2033 0         0 my $not_anchor = '';
2034              
2035 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2036             }
2037 0 0       0 if (scalar(@multipleoctet) >= 2) {
2038 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2039             }
2040             else {
2041 0         0 return $multipleoctet[0];
2042             }
2043             }
2044              
2045             #
2046             # Latin-10 open character list for not qr
2047             #
2048             sub charlist_not_qr {
2049              
2050 0     0 0 0 my $modifier = pop @_;
2051 0         0 my @char = @_;
2052              
2053 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2054 0         0 my @singleoctet = @$singleoctet;
2055 0         0 my @multipleoctet = @$multipleoctet;
2056              
2057             # with /i modifier
2058 0 0       0 if ($modifier =~ m/i/oxms) {
2059 0         0 my %singleoctet_ignorecase = ();
2060 0         0 for (@singleoctet) {
2061 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2062 0         0 for my $ord (hex($1) .. hex($2)) {
2063 0         0 my $char = CORE::chr($ord);
2064 0         0 my $uc = Elatin10::uc($char);
2065 0         0 my $fc = Elatin10::fc($char);
2066 0 0       0 if ($uc eq $fc) {
2067 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2068             }
2069             else {
2070 0 0       0 if (CORE::length($fc) == 1) {
2071 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2072 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2073             }
2074             else {
2075 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2076 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2077             }
2078             }
2079             }
2080             }
2081 0 0       0 if ($_ ne '') {
2082 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2083             }
2084             }
2085 0         0 my $i = 0;
2086 0         0 my @singleoctet_ignorecase = ();
2087 0         0 for my $ord (0 .. 255) {
2088 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2089 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2090             }
2091             else {
2092 0         0 $i++;
2093             }
2094             }
2095 0         0 @singleoctet = ();
2096 0         0 for my $range (@singleoctet_ignorecase) {
2097 0 0       0 if (ref $range) {
2098 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2099 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2100             }
2101             elsif (scalar(@{$range}) == 2) {
2102 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2103             }
2104             else {
2105 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2106             }
2107             }
2108             }
2109             }
2110              
2111             # return character list
2112 0 0       0 if (scalar(@multipleoctet) >= 1) {
2113 0 0       0 if (scalar(@singleoctet) >= 1) {
2114              
2115             # any character other than multiple-octet and single octet character class
2116 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2117             }
2118             else {
2119              
2120             # any character other than multiple-octet character class
2121 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2122             }
2123             }
2124             else {
2125 0 0       0 if (scalar(@singleoctet) >= 1) {
2126              
2127             # any character other than single octet character class
2128 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2129             }
2130             else {
2131              
2132             # any character
2133 0         0 return "(?:$your_char)";
2134             }
2135             }
2136             }
2137              
2138             #
2139             # open file in read mode
2140             #
2141             sub _open_r {
2142 200     200   661 my(undef,$file) = @_;
2143 200         917 $file =~ s#\A (\s) #./$1#oxms;
2144 200   33     23269 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2145             open($_[0],"< $file\0");
2146             }
2147              
2148             #
2149             # open file in write mode
2150             #
2151             sub _open_w {
2152 0     0   0 my(undef,$file) = @_;
2153 0         0 $file =~ s#\A (\s) #./$1#oxms;
2154 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2155             open($_[0],"> $file\0");
2156             }
2157              
2158             #
2159             # open file in append mode
2160             #
2161             sub _open_a {
2162 0     0   0 my(undef,$file) = @_;
2163 0         0 $file =~ s#\A (\s) #./$1#oxms;
2164 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2165             open($_[0],">> $file\0");
2166             }
2167              
2168             #
2169             # safe system
2170             #
2171             sub _systemx {
2172              
2173             # P.707 29.2.33. exec
2174             # in Chapter 29: Functions
2175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2176             #
2177             # Be aware that in older releases of Perl, 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 in the case of exec, or
2180             # misordererd output in the case of system. This situation was largely remedied
2181             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2182              
2183             # P.855 exec
2184             # in Chapter 27: Functions
2185             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2186             #
2187             # In very old release of Perl (before v5.6), exec (and system) did not flush
2188             # your output buffer, so you needed to enable command buffering by setting $|
2189             # on one or more filehandles to avoid lost output with exec or misordered
2190             # output with system.
2191              
2192 200     200   779 $| = 1;
2193              
2194             # P.565 23.1.2. Cleaning Up Your Environment
2195             # in Chapter 23: Security
2196             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2197              
2198             # P.656 Cleaning Up Your Environment
2199             # in Chapter 20: Security
2200             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2201              
2202             # local $ENV{'PATH'} = '.';
2203 200         2708 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2204              
2205             # P.707 29.2.33. exec
2206             # in Chapter 29: Functions
2207             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2208             #
2209             # As we mentioned earlier, exec treats a discrete list of arguments as an
2210             # indication that it should bypass shell processing. However, there is one
2211             # place where you might still get tripped up. The exec call (and system, too)
2212             # will not distinguish between a single scalar argument and an array containing
2213             # only one element.
2214             #
2215             # @args = ("echo surprise"); # just one element in list
2216             # exec @args # still subject to shell escapes
2217             # or die "exec: $!"; # because @args == 1
2218             #
2219             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2220             # first argument as the pathname, which forces the rest of the arguments to be
2221             # interpreted as a list, even if there is only one of them:
2222             #
2223             # exec { $args[0] } @args # safe even with one-argument list
2224             # or die "can't exec @args: $!";
2225              
2226             # P.855 exec
2227             # in Chapter 27: Functions
2228             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2229             #
2230             # As we mentioned earlier, exec treats a discrete list of arguments as a
2231             # directive to bypass shell processing. However, there is one place where
2232             # you might still get tripped up. The exec call (and system, too) cannot
2233             # distinguish between a single scalar argument and an array containing
2234             # only one element.
2235             #
2236             # @args = ("echo surprise"); # just one element in list
2237             # exec @args # still subject to shell escapes
2238             # || die "exec: $!"; # because @args == 1
2239             #
2240             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2241             # argument as the pathname, which forces the rest of the arguments to be
2242             # interpreted as a list, even if there is only one of them:
2243             #
2244             # exec { $args[0] } @args # safe even with one-argument list
2245             # || die "can't exec @args: $!";
2246              
2247 200         425 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         25308422  
2248             }
2249              
2250             #
2251             # Latin-10 order to character (with parameter)
2252             #
2253             sub Elatin10::chr(;$) {
2254              
2255 0 0   0 0   my $c = @_ ? $_[0] : $_;
2256              
2257 0 0         if ($c == 0x00) {
2258 0           return "\x00";
2259             }
2260             else {
2261 0           my @chr = ();
2262 0           while ($c > 0) {
2263 0           unshift @chr, ($c % 0x100);
2264 0           $c = int($c / 0x100);
2265             }
2266 0           return pack 'C*', @chr;
2267             }
2268             }
2269              
2270             #
2271             # Latin-10 order to character (without parameter)
2272             #
2273             sub Elatin10::chr_() {
2274              
2275 0     0 0   my $c = $_;
2276              
2277 0 0         if ($c == 0x00) {
2278 0           return "\x00";
2279             }
2280             else {
2281 0           my @chr = ();
2282 0           while ($c > 0) {
2283 0           unshift @chr, ($c % 0x100);
2284 0           $c = int($c / 0x100);
2285             }
2286 0           return pack 'C*', @chr;
2287             }
2288             }
2289              
2290             #
2291             # Latin-10 path globbing (with parameter)
2292             #
2293             sub Elatin10::glob($) {
2294              
2295 0 0   0 0   if (wantarray) {
2296 0           my @glob = _DOS_like_glob(@_);
2297 0           for my $glob (@glob) {
2298 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2299             }
2300 0           return @glob;
2301             }
2302             else {
2303 0           my $glob = _DOS_like_glob(@_);
2304 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2305 0           return $glob;
2306             }
2307             }
2308              
2309             #
2310             # Latin-10 path globbing (without parameter)
2311             #
2312             sub Elatin10::glob_() {
2313              
2314 0 0   0 0   if (wantarray) {
2315 0           my @glob = _DOS_like_glob();
2316 0           for my $glob (@glob) {
2317 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2318             }
2319 0           return @glob;
2320             }
2321             else {
2322 0           my $glob = _DOS_like_glob();
2323 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2324 0           return $glob;
2325             }
2326             }
2327              
2328             #
2329             # Latin-10 path globbing via File::DosGlob 1.10
2330             #
2331             # Often I confuse "_dosglob" and "_doglob".
2332             # So, I renamed "_dosglob" to "_DOS_like_glob".
2333             #
2334             my %iter;
2335             my %entries;
2336             sub _DOS_like_glob {
2337              
2338             # context (keyed by second cxix argument provided by core)
2339 0     0     my($expr,$cxix) = @_;
2340              
2341             # glob without args defaults to $_
2342 0 0         $expr = $_ if not defined $expr;
2343              
2344             # represents the current user's home directory
2345             #
2346             # 7.3. Expanding Tildes in Filenames
2347             # in Chapter 7. File Access
2348             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2349             #
2350             # and File::HomeDir, File::HomeDir::Windows module
2351              
2352             # DOS-like system
2353 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2354 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2355 0           { my_home_MSWin32() }oxmse;
2356             }
2357              
2358             # UNIX-like system
2359             else {
2360 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2361 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2362             }
2363              
2364             # assume global context if not provided one
2365 0 0         $cxix = '_G_' if not defined $cxix;
2366 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2367              
2368             # if we're just beginning, do it all first
2369 0 0         if ($iter{$cxix} == 0) {
2370 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2371             }
2372              
2373             # chuck it all out, quick or slow
2374 0 0         if (wantarray) {
2375 0           delete $iter{$cxix};
2376 0           return @{delete $entries{$cxix}};
  0            
2377             }
2378             else {
2379 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2380 0           return shift @{$entries{$cxix}};
  0            
2381             }
2382             else {
2383             # return undef for EOL
2384 0           delete $iter{$cxix};
2385 0           delete $entries{$cxix};
2386 0           return undef;
2387             }
2388             }
2389             }
2390              
2391             #
2392             # Latin-10 path globbing subroutine
2393             #
2394             sub _do_glob {
2395              
2396 0     0     my($cond,@expr) = @_;
2397 0           my @glob = ();
2398 0           my $fix_drive_relative_paths = 0;
2399              
2400             OUTER:
2401 0           for my $expr (@expr) {
2402 0 0         next OUTER if not defined $expr;
2403 0 0         next OUTER if $expr eq '';
2404              
2405 0           my @matched = ();
2406 0           my @globdir = ();
2407 0           my $head = '.';
2408 0           my $pathsep = '/';
2409 0           my $tail;
2410              
2411             # if argument is within quotes strip em and do no globbing
2412 0 0         if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2413 0           $expr = $1;
2414 0 0         if ($cond eq 'd') {
2415 0 0         if (-d $expr) {
2416 0           push @glob, $expr;
2417             }
2418             }
2419             else {
2420 0 0         if (-e $expr) {
2421 0           push @glob, $expr;
2422             }
2423             }
2424 0           next OUTER;
2425             }
2426              
2427             # wildcards with a drive prefix such as h:*.pm must be changed
2428             # to h:./*.pm to expand correctly
2429 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2430 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2431 0           $fix_drive_relative_paths = 1;
2432             }
2433             }
2434              
2435 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2436 0 0         if ($tail eq '') {
2437 0           push @glob, $expr;
2438 0           next OUTER;
2439             }
2440 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2441 0 0         if (@globdir = _do_glob('d', $head)) {
2442 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2443 0           next OUTER;
2444             }
2445             }
2446 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2447 0           $head .= $pathsep;
2448             }
2449 0           $expr = $tail;
2450             }
2451              
2452             # If file component has no wildcards, we can avoid opendir
2453 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2454 0 0         if ($head eq '.') {
2455 0           $head = '';
2456             }
2457 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2458 0           $head .= $pathsep;
2459             }
2460 0           $head .= $expr;
2461 0 0         if ($cond eq 'd') {
2462 0 0         if (-d $head) {
2463 0           push @glob, $head;
2464             }
2465             }
2466             else {
2467 0 0         if (-e $head) {
2468 0           push @glob, $head;
2469             }
2470             }
2471 0           next OUTER;
2472             }
2473 0 0         opendir(*DIR, $head) or next OUTER;
2474 0           my @leaf = readdir DIR;
2475 0           closedir DIR;
2476              
2477 0 0         if ($head eq '.') {
2478 0           $head = '';
2479             }
2480 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2481 0           $head .= $pathsep;
2482             }
2483              
2484 0           my $pattern = '';
2485 0           while ($expr =~ / \G ($q_char) /oxgc) {
2486 0           my $char = $1;
2487              
2488             # 6.9. Matching Shell Globs as Regular Expressions
2489             # in Chapter 6. Pattern Matching
2490             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2491             # (and so on)
2492              
2493 0 0         if ($char eq '*') {
    0          
    0          
2494 0           $pattern .= "(?:$your_char)*",
2495             }
2496             elsif ($char eq '?') {
2497 0           $pattern .= "(?:$your_char)?", # DOS style
2498             # $pattern .= "(?:$your_char)", # UNIX style
2499             }
2500             elsif ((my $fc = Elatin10::fc($char)) ne $char) {
2501 0           $pattern .= $fc;
2502             }
2503             else {
2504 0           $pattern .= quotemeta $char;
2505             }
2506             }
2507 0     0     my $matchsub = sub { Elatin10::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2508              
2509             # if ($@) {
2510             # print STDERR "$0: $@\n";
2511             # next OUTER;
2512             # }
2513              
2514             INNER:
2515 0           for my $leaf (@leaf) {
2516 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2517 0           next INNER;
2518             }
2519 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2520 0           next INNER;
2521             }
2522              
2523 0 0         if (&$matchsub($leaf)) {
2524 0           push @matched, "$head$leaf";
2525 0           next INNER;
2526             }
2527              
2528             # [DOS compatibility special case]
2529             # Failed, add a trailing dot and try again, but only...
2530              
2531 0 0 0       if (Elatin10::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2532             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2533             Elatin10::index($pattern,'\\.') != -1 # pattern has a dot.
2534             ) {
2535 0 0         if (&$matchsub("$leaf.")) {
2536 0           push @matched, "$head$leaf";
2537 0           next INNER;
2538             }
2539             }
2540             }
2541 0 0         if (@matched) {
2542 0           push @glob, @matched;
2543             }
2544             }
2545 0 0         if ($fix_drive_relative_paths) {
2546 0           for my $glob (@glob) {
2547 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2548             }
2549             }
2550 0           return @glob;
2551             }
2552              
2553             #
2554             # Latin-10 parse line
2555             #
2556             sub _parse_line {
2557              
2558 0     0     my($line) = @_;
2559              
2560 0           $line .= ' ';
2561 0           my @piece = ();
2562 0           while ($line =~ /
2563             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2564             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2565             /oxmsg
2566             ) {
2567 0 0         push @piece, defined($1) ? $1 : $2;
2568             }
2569 0           return @piece;
2570             }
2571              
2572             #
2573             # Latin-10 parse path
2574             #
2575             sub _parse_path {
2576              
2577 0     0     my($path,$pathsep) = @_;
2578              
2579 0           $path .= '/';
2580 0           my @subpath = ();
2581 0           while ($path =~ /
2582             ((?: [^\/\\] )+?) [\/\\]
2583             /oxmsg
2584             ) {
2585 0           push @subpath, $1;
2586             }
2587              
2588 0           my $tail = pop @subpath;
2589 0           my $head = join $pathsep, @subpath;
2590 0           return $head, $tail;
2591             }
2592              
2593             #
2594             # via File::HomeDir::Windows 1.00
2595             #
2596             sub my_home_MSWin32 {
2597              
2598             # A lot of unix people and unix-derived tools rely on
2599             # the ability to overload HOME. We will support it too
2600             # so that they can replace raw HOME calls with File::HomeDir.
2601 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2602 0           return $ENV{'HOME'};
2603             }
2604              
2605             # Do we have a user profile?
2606             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2607 0           return $ENV{'USERPROFILE'};
2608             }
2609              
2610             # Some Windows use something like $ENV{'HOME'}
2611             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2612 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2613             }
2614              
2615 0           return undef;
2616             }
2617              
2618             #
2619             # via File::HomeDir::Unix 1.00
2620             #
2621             sub my_home {
2622 0     0 0   my $home;
2623              
2624 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2625 0           $home = $ENV{'HOME'};
2626             }
2627              
2628             # This is from the original code, but I'm guessing
2629             # it means "login directory" and exists on some Unixes.
2630             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2631 0           $home = $ENV{'LOGDIR'};
2632             }
2633              
2634             ### More-desperate methods
2635              
2636             # Light desperation on any (Unixish) platform
2637             else {
2638 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2639             }
2640              
2641             # On Unix in general, a non-existant home means "no home"
2642             # For example, "nobody"-like users might use /nonexistant
2643 0 0 0       if (defined $home and ! -d($home)) {
2644 0           $home = undef;
2645             }
2646 0           return $home;
2647             }
2648              
2649             #
2650             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2651             #
2652             sub Elatin10::PREMATCH {
2653 0     0 0   return $`;
2654             }
2655              
2656             #
2657             # ${^MATCH}, $MATCH, $& the string that matched
2658             #
2659             sub Elatin10::MATCH {
2660 0     0 0   return $&;
2661             }
2662              
2663             #
2664             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2665             #
2666             sub Elatin10::POSTMATCH {
2667 0     0 0   return $';
2668             }
2669              
2670             #
2671             # Latin-10 character to order (with parameter)
2672             #
2673             sub Latin10::ord(;$) {
2674              
2675 0 0   0 1   local $_ = shift if @_;
2676              
2677 0 0         if (/\A ($q_char) /oxms) {
2678 0           my @ord = unpack 'C*', $1;
2679 0           my $ord = 0;
2680 0           while (my $o = shift @ord) {
2681 0           $ord = $ord * 0x100 + $o;
2682             }
2683 0           return $ord;
2684             }
2685             else {
2686 0           return CORE::ord $_;
2687             }
2688             }
2689              
2690             #
2691             # Latin-10 character to order (without parameter)
2692             #
2693             sub Latin10::ord_() {
2694              
2695 0 0   0 0   if (/\A ($q_char) /oxms) {
2696 0           my @ord = unpack 'C*', $1;
2697 0           my $ord = 0;
2698 0           while (my $o = shift @ord) {
2699 0           $ord = $ord * 0x100 + $o;
2700             }
2701 0           return $ord;
2702             }
2703             else {
2704 0           return CORE::ord $_;
2705             }
2706             }
2707              
2708             #
2709             # Latin-10 reverse
2710             #
2711             sub Latin10::reverse(@) {
2712              
2713 0 0   0 0   if (wantarray) {
2714 0           return CORE::reverse @_;
2715             }
2716             else {
2717              
2718             # One of us once cornered Larry in an elevator and asked him what
2719             # problem he was solving with this, but he looked as far off into
2720             # the distance as he could in an elevator and said, "It seemed like
2721             # a good idea at the time."
2722              
2723 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2724             }
2725             }
2726              
2727             #
2728             # Latin-10 getc (with parameter, without parameter)
2729             #
2730             sub Latin10::getc(;*@) {
2731              
2732 0     0 0   my($package) = caller;
2733 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2734 0 0 0       croak 'Too many arguments for Latin10::getc' if @_ and not wantarray;
2735              
2736 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2737 0           my $getc = '';
2738 0           for my $length ($length[0] .. $length[-1]) {
2739 0           $getc .= CORE::getc($fh);
2740 0 0         if (exists $range_tr{CORE::length($getc)}) {
2741 0 0         if ($getc =~ /\A ${Elatin10::dot_s} \z/oxms) {
2742 0 0         return wantarray ? ($getc,@_) : $getc;
2743             }
2744             }
2745             }
2746 0 0         return wantarray ? ($getc,@_) : $getc;
2747             }
2748              
2749             #
2750             # Latin-10 length by character
2751             #
2752             sub Latin10::length(;$) {
2753              
2754 0 0   0 1   local $_ = shift if @_;
2755              
2756 0           local @_ = /\G ($q_char) /oxmsg;
2757 0           return scalar @_;
2758             }
2759              
2760             #
2761             # Latin-10 substr by character
2762             #
2763             BEGIN {
2764              
2765             # P.232 The lvalue Attribute
2766             # in Chapter 6: Subroutines
2767             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2768              
2769             # P.336 The lvalue Attribute
2770             # in Chapter 7: Subroutines
2771             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2772              
2773             # P.144 8.4 Lvalue subroutines
2774             # in Chapter 8: perlsub: Perl subroutines
2775             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2776              
2777 200 50 0 200 1 157536 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  0 0   0      
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
2778             # vv----------------------*******
2779             sub Latin10::substr($$;$$) %s {
2780              
2781             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2782              
2783             # If the substring is beyond either end of the string, substr() returns the undefined
2784             # value and produces a warning. When used as an lvalue, specifying a substring that
2785             # is entirely outside the string raises an exception.
2786             # http://perldoc.perl.org/functions/substr.html
2787              
2788             # A return with no argument returns the scalar value undef in scalar context,
2789             # an empty list () in list context, and (naturally) nothing at all in void
2790             # context.
2791              
2792             my $offset = $_[1];
2793             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2794             return;
2795             }
2796              
2797             # substr($string,$offset,$length,$replacement)
2798             if (@_ == 4) {
2799             my(undef,undef,$length,$replacement) = @_;
2800             my $substr = join '', splice(@char, $offset, $length, $replacement);
2801             $_[0] = join '', @char;
2802              
2803             # return $substr; this doesn't work, don't say "return"
2804             $substr;
2805             }
2806              
2807             # substr($string,$offset,$length)
2808             elsif (@_ == 3) {
2809             my(undef,undef,$length) = @_;
2810             my $octet_offset = 0;
2811             my $octet_length = 0;
2812             if ($offset == 0) {
2813             $octet_offset = 0;
2814             }
2815             elsif ($offset > 0) {
2816             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2817             }
2818             else {
2819             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2820             }
2821             if ($length == 0) {
2822             $octet_length = 0;
2823             }
2824             elsif ($length > 0) {
2825             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2826             }
2827             else {
2828             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2829             }
2830             CORE::substr($_[0], $octet_offset, $octet_length);
2831             }
2832              
2833             # substr($string,$offset)
2834             else {
2835             my $octet_offset = 0;
2836             if ($offset == 0) {
2837             $octet_offset = 0;
2838             }
2839             elsif ($offset > 0) {
2840             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2841             }
2842             else {
2843             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2844             }
2845             CORE::substr($_[0], $octet_offset);
2846             }
2847             }
2848             END
2849             }
2850              
2851             #
2852             # Latin-10 index by character
2853             #
2854             sub Latin10::index($$;$) {
2855              
2856 0     0 1   my $index;
2857 0 0         if (@_ == 3) {
2858 0           $index = Elatin10::index($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2859             }
2860             else {
2861 0           $index = Elatin10::index($_[0], $_[1]);
2862             }
2863              
2864 0 0         if ($index == -1) {
2865 0           return -1;
2866             }
2867             else {
2868 0           return Latin10::length(CORE::substr $_[0], 0, $index);
2869             }
2870             }
2871              
2872             #
2873             # Latin-10 rindex by character
2874             #
2875             sub Latin10::rindex($$;$) {
2876              
2877 0     0 1   my $rindex;
2878 0 0         if (@_ == 3) {
2879 0           $rindex = Elatin10::rindex($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2880             }
2881             else {
2882 0           $rindex = Elatin10::rindex($_[0], $_[1]);
2883             }
2884              
2885 0 0         if ($rindex == -1) {
2886 0           return -1;
2887             }
2888             else {
2889 0           return Latin10::length(CORE::substr $_[0], 0, $rindex);
2890             }
2891             }
2892              
2893             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2894             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2895 200     200   20187 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   2079  
  200         441  
  200         16541  
2896              
2897             # ord() to ord() or Latin10::ord()
2898 200     200   15211 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1431  
  200         421  
  200         26755  
2899              
2900             # ord to ord or Latin10::ord_
2901 200     200   15336 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   1191  
  200         381  
  200         13496  
2902              
2903             # reverse to reverse or Latin10::reverse
2904 200     200   14355 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   1190  
  200         373  
  200         14481  
2905              
2906             # getc to getc or Latin10::getc
2907 200     200   15080 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   1189  
  200         369  
  200         15117  
2908              
2909             # P.1023 Appendix W.9 Multibyte Anchoring
2910             # of ISBN 1-56592-224-7 CJKV Information Processing
2911              
2912             my $anchor = '';
2913              
2914 200     200   18427 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   1356  
  200         15494  
  200         13672325  
2915              
2916             # regexp of nested parens in qqXX
2917              
2918             # P.340 Matching Nested Constructs with Embedded Code
2919             # in Chapter 7: Perl
2920             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2921              
2922             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2923             [^\\()] |
2924             \( (?{$nest++}) |
2925             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2926             \\ [^c] |
2927             \\c[\x40-\x5F] |
2928             [\x00-\xFF]
2929             }xms;
2930              
2931             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2932             [^\\{}] |
2933             \{ (?{$nest++}) |
2934             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2935             \\ [^c] |
2936             \\c[\x40-\x5F] |
2937             [\x00-\xFF]
2938             }xms;
2939              
2940             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2941             [^\\\[\]] |
2942             \[ (?{$nest++}) |
2943             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2944             \\ [^c] |
2945             \\c[\x40-\x5F] |
2946             [\x00-\xFF]
2947             }xms;
2948              
2949             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2950             [^\\<>] |
2951             \< (?{$nest++}) |
2952             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2953             \\ [^c] |
2954             \\c[\x40-\x5F] |
2955             [\x00-\xFF]
2956             }xms;
2957              
2958             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2959             (?: ::)? (?:
2960             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2961             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2962             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2963             ))
2964             }xms;
2965              
2966             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2967             (?: ::)? (?:
2968             (?>[0-9]+) |
2969             [^a-zA-Z_0-9\[\]] |
2970             ^[A-Z] |
2971             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2972             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2973             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2974             ))
2975             }xms;
2976              
2977             my $qq_substr = qr{(?> Char::substr | Latin10::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2978             }xms;
2979              
2980             # regexp of nested parens in qXX
2981             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2982             [^()] |
2983             \( (?{$nest++}) |
2984             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2985             [\x00-\xFF]
2986             }xms;
2987              
2988             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2989             [^\{\}] |
2990             \{ (?{$nest++}) |
2991             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2992             [\x00-\xFF]
2993             }xms;
2994              
2995             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2996             [^\[\]] |
2997             \[ (?{$nest++}) |
2998             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2999             [\x00-\xFF]
3000             }xms;
3001              
3002             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3003             [^<>] |
3004             \< (?{$nest++}) |
3005             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3006             [\x00-\xFF]
3007             }xms;
3008              
3009             my $matched = '';
3010             my $s_matched = '';
3011              
3012             my $tr_variable = ''; # variable of tr///
3013             my $sub_variable = ''; # variable of s///
3014             my $bind_operator = ''; # =~ or !~
3015              
3016             my @heredoc = (); # here document
3017             my @heredoc_delimiter = ();
3018             my $here_script = ''; # here script
3019              
3020             #
3021             # escape Latin-10 script
3022             #
3023             sub Latin10::escape(;$) {
3024 0 0   0 0   local($_) = $_[0] if @_;
3025              
3026             # P.359 The Study Function
3027             # in Chapter 7: Perl
3028             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3029              
3030 0           study $_; # Yes, I studied study yesterday.
3031              
3032             # while all script
3033              
3034             # 6.14. Matching from Where the Last Pattern Left Off
3035             # in Chapter 6. Pattern Matching
3036             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3037             # (and so on)
3038              
3039             # one member of Tag-team
3040             #
3041             # P.128 Start of match (or end of previous match): \G
3042             # P.130 Advanced Use of \G with Perl
3043             # in Chapter 3: Overview of Regular Expression Features and Flavors
3044             # P.255 Use leading anchors
3045             # P.256 Expose ^ and \G at the front expressions
3046             # in Chapter 6: Crafting an Efficient Expression
3047             # P.315 "Tag-team" matching with /gc
3048             # in Chapter 7: Perl
3049             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3050              
3051 0           my $e_script = '';
3052 0           while (not /\G \z/oxgc) { # member
3053 0           $e_script .= Latin10::escape_token();
3054             }
3055              
3056 0           return $e_script;
3057             }
3058              
3059             #
3060             # escape Latin-10 token of script
3061             #
3062             sub Latin10::escape_token {
3063              
3064             # \n output here document
3065              
3066 0     0 0   my $ignore_modules = join('|', qw(
3067             utf8
3068             bytes
3069             charnames
3070             I18N::Japanese
3071             I18N::Collate
3072             I18N::JExt
3073             File::DosGlob
3074             Wild
3075             Wildcard
3076             Japanese
3077             ));
3078              
3079             # another member of Tag-team
3080             #
3081             # P.315 "Tag-team" matching with /gc
3082             # in Chapter 7: Perl
3083             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3084              
3085 0 0 0       if (/\G ( \n ) /oxgc) { # another member (and so on)
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3086 0           my $heredoc = '';
3087 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3088 0           $slash = 'm//';
3089              
3090 0           $heredoc = join '', @heredoc;
3091 0           @heredoc = ();
3092              
3093             # skip here document
3094 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3095 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3096             }
3097 0           @heredoc_delimiter = ();
3098              
3099 0           $here_script = '';
3100             }
3101 0           return "\n" . $heredoc;
3102             }
3103              
3104             # ignore space, comment
3105 0           elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3106              
3107             # if (, elsif (, unless (, while (, until (, given (, and when (
3108              
3109             # given, when
3110              
3111             # P.225 The given Statement
3112             # in Chapter 15: Smart Matching and given-when
3113             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3114              
3115             # P.133 The given Statement
3116             # in Chapter 4: Statements and Declarations
3117             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3118              
3119             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3120 0           $slash = 'm//';
3121 0           return $1;
3122             }
3123              
3124             # scalar variable ($scalar = ...) =~ tr///;
3125             # scalar variable ($scalar = ...) =~ s///;
3126              
3127             # state
3128              
3129             # P.68 Persistent, Private Variables
3130             # in Chapter 4: Subroutines
3131             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3132              
3133             # P.160 Persistent Lexically Scoped Variables: state
3134             # in Chapter 4: Statements and Declarations
3135             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3136              
3137             # (and so on)
3138              
3139             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3140 0           my $e_string = e_string($1);
3141              
3142 0 0         if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3143 0           $tr_variable = $e_string . e_string($1);
3144 0           $bind_operator = $2;
3145 0           $slash = 'm//';
3146 0           return '';
3147             }
3148             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3149 0           $sub_variable = $e_string . e_string($1);
3150 0           $bind_operator = $2;
3151 0           $slash = 'm//';
3152 0           return '';
3153             }
3154             else {
3155 0           $slash = 'div';
3156 0           return $e_string;
3157             }
3158             }
3159              
3160             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
3161             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3162 0           $slash = 'div';
3163 0           return q{Elatin10::PREMATCH()};
3164             }
3165              
3166             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
3167             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3168 0           $slash = 'div';
3169 0           return q{Elatin10::MATCH()};
3170             }
3171              
3172             # $', ${'} --> $', ${'}
3173             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3174 0           $slash = 'div';
3175 0           return $1;
3176             }
3177              
3178             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
3179             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3180 0           $slash = 'div';
3181 0           return q{Elatin10::POSTMATCH()};
3182             }
3183              
3184             # scalar variable $scalar =~ tr///;
3185             # scalar variable $scalar =~ s///;
3186             # substr() =~ tr///;
3187             # substr() =~ s///;
3188             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3189 0           my $scalar = e_string($1);
3190              
3191 0 0         if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3192 0           $tr_variable = $scalar;
3193 0           $bind_operator = $1;
3194 0           $slash = 'm//';
3195 0           return '';
3196             }
3197             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3198 0           $sub_variable = $scalar;
3199 0           $bind_operator = $1;
3200 0           $slash = 'm//';
3201 0           return '';
3202             }
3203             else {
3204 0           $slash = 'div';
3205 0           return $scalar;
3206             }
3207             }
3208              
3209             # end of statement
3210             elsif (/\G ( [,;] ) /oxgc) {
3211 0           $slash = 'm//';
3212              
3213             # clear tr/// variable
3214 0           $tr_variable = '';
3215              
3216             # clear s/// variable
3217 0           $sub_variable = '';
3218              
3219 0           $bind_operator = '';
3220              
3221 0           return $1;
3222             }
3223              
3224             # bareword
3225             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3226 0           return $1;
3227             }
3228              
3229             # $0 --> $0
3230             elsif (/\G ( \$ 0 ) /oxmsgc) {
3231 0           $slash = 'div';
3232 0           return $1;
3233             }
3234             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3235 0           $slash = 'div';
3236 0           return $1;
3237             }
3238              
3239             # $$ --> $$
3240             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3241 0           $slash = 'div';
3242 0           return $1;
3243             }
3244              
3245             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3246             # $1, $2, $3 --> $1, $2, $3 otherwise
3247             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3248 0           $slash = 'div';
3249 0           return e_capture($1);
3250             }
3251             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3252 0           $slash = 'div';
3253 0           return e_capture($1);
3254             }
3255              
3256             # $$foo[ ... ] --> $ $foo->[ ... ]
3257             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3258 0           $slash = 'div';
3259 0           return e_capture($1.'->'.$2);
3260             }
3261              
3262             # $$foo{ ... } --> $ $foo->{ ... }
3263             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3264 0           $slash = 'div';
3265 0           return e_capture($1.'->'.$2);
3266             }
3267              
3268             # $$foo
3269             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3270 0           $slash = 'div';
3271 0           return e_capture($1);
3272             }
3273              
3274             # ${ foo }
3275             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3276 0           $slash = 'div';
3277 0           return '${' . $1 . '}';
3278             }
3279              
3280             # ${ ... }
3281             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3282 0           $slash = 'div';
3283 0           return e_capture($1);
3284             }
3285              
3286             # variable or function
3287             # $ @ % & * $ #
3288             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) {
3289 0           $slash = 'div';
3290 0           return $1;
3291             }
3292             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3293             # $ @ # \ ' " / ? ( ) [ ] < >
3294             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3295 0           $slash = 'div';
3296 0           return $1;
3297             }
3298              
3299             # while ()
3300             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3301 0           return $1;
3302             }
3303              
3304             # while () --- glob
3305              
3306             # avoid "Error: Runtime exception" of perl version 5.005_03
3307              
3308             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3309 0           return 'while ($_ = Elatin10::glob("' . $1 . '"))';
3310             }
3311              
3312             # while (glob)
3313             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3314 0           return 'while ($_ = Elatin10::glob_)';
3315             }
3316              
3317             # while (glob(WILDCARD))
3318             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3319 0           return 'while ($_ = Elatin10::glob';
3320             }
3321              
3322             # doit if, doit unless, doit while, doit until, doit for, doit when
3323 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3324              
3325             # subroutines of package Elatin10
3326 0           elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3327 0           elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3328 0           elsif (/\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3329 0           elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0            
3330 0           elsif (/\G \b Latin10::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin10::escape'; }
  0            
3331 0           elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3332 0           elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chop'; }
  0            
3333 0           elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3334 0           elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0            
3335 0           elsif (/\G \b Latin10::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::index'; }
  0            
3336 0           elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::index'; }
  0            
3337 0           elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3338 0           elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0            
3339 0           elsif (/\G \b Latin10::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::rindex'; }
  0            
3340 0           elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::rindex'; }
  0            
3341 0           elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lc'; }
  0            
3342 0           elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst'; }
  0            
3343 0           elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::uc'; }
  0            
3344 0           elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst'; }
  0            
3345 0           elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::fc'; }
  0            
3346              
3347             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3348 0           elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3349 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3350 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3351 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3352 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3353 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3354 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3355              
3356 0           elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3357 0           elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3358 0           elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3359 0           elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3360 0           elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3361 0           elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3362 0           elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3363              
3364             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3365 0           { $slash = 'm//'; return "-s $1"; }
  0            
3366 0           elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3367 0           elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3368 0           elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3369              
3370 0           elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3371 0           elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3372 0           elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::chr'; }
  0            
3373 0           elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3374 0           elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3375 0           elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::glob'; }
  0            
3376 0           elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lc_'; }
  0            
3377 0           elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst_'; }
  0            
3378 0           elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::uc_'; }
  0            
3379 0           elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst_'; }
  0            
3380 0           elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::fc_'; }
  0            
3381 0           elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3382              
3383 0           elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3384 0           elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3385 0           elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chr_'; }
  0            
3386 0           elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3387 0           elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3388 0           elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::glob_'; }
  0            
3389 0           elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3390 0           elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3391             # split
3392             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3393 0           $slash = 'm//';
3394              
3395 0           my $e = '';
3396 0           while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3397 0           $e .= $1;
3398             }
3399              
3400             # end of split
3401 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3402              
3403             # split scalar value
3404 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin10::split' . $e . e_string($1); }
3405              
3406             # split literal space
3407 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {qq$1 $2}; }
3408 0           elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3409 0           elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3410 0           elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3411 0           elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3412 0           elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3413 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {q$1 $2}; }
3414 0           elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3415 0           elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3416 0           elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3417 0           elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3418 0           elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3419 0           elsif (/\G ' [ ] ' /oxgc) { return 'Elatin10::split' . $e . qq {' '}; }
3420 0           elsif (/\G " [ ] " /oxgc) { return 'Elatin10::split' . $e . qq {" "}; }
3421              
3422             # split qq//
3423             elsif (/\G \b (qq) \b /oxgc) {
3424 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3425             else {
3426 0           while (not /\G \z/oxgc) {
3427 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3428 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3429 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3430 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3431 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3432 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3433 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3434             }
3435 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3436             }
3437             }
3438              
3439             # split qr//
3440             elsif (/\G \b (qr) \b /oxgc) {
3441 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3442             else {
3443 0           while (not /\G \z/oxgc) {
3444 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3445 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3446 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3447 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3448 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3449 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3450 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3451 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3452             }
3453 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3454             }
3455             }
3456              
3457             # split q//
3458             elsif (/\G \b (q) \b /oxgc) {
3459 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3460             else {
3461 0           while (not /\G \z/oxgc) {
3462 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3463 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3464 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3465 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3466 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3467 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3468 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3469             }
3470 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3471             }
3472             }
3473              
3474             # split m//
3475             elsif (/\G \b (m) \b /oxgc) {
3476 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3477             else {
3478 0           while (not /\G \z/oxgc) {
3479 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3480 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3481 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3482 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3483 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3484 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3485 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3486 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3487             }
3488 0           die __FILE__, ": Search pattern not terminated\n";
3489             }
3490             }
3491              
3492             # split ''
3493             elsif (/\G (\') /oxgc) {
3494 0           my $q_string = '';
3495 0           while (not /\G \z/oxgc) {
3496 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3497 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3498 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3499 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3500             }
3501 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3502             }
3503              
3504             # split ""
3505             elsif (/\G (\") /oxgc) {
3506 0           my $qq_string = '';
3507 0           while (not /\G \z/oxgc) {
3508 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3509 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3510 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3511 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3512             }
3513 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3514             }
3515              
3516             # split //
3517             elsif (/\G (\/) /oxgc) {
3518 0           my $regexp = '';
3519 0           while (not /\G \z/oxgc) {
3520 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3521 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3522 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3523 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3524             }
3525 0           die __FILE__, ": Search pattern not terminated\n";
3526             }
3527             }
3528              
3529             # tr/// or y///
3530              
3531             # about [cdsrbB]* (/B modifier)
3532             #
3533             # P.559 appendix C
3534             # of ISBN 4-89052-384-7 Programming perl
3535             # (Japanese title is: Perl puroguramingu)
3536              
3537             elsif (/\G \b ( tr | y ) \b /oxgc) {
3538 0           my $ope = $1;
3539              
3540             # $1 $2 $3 $4 $5 $6
3541 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3542 0           my @tr = ($tr_variable,$2);
3543 0           return e_tr(@tr,'',$4,$6);
3544             }
3545             else {
3546 0           my $e = '';
3547 0           while (not /\G \z/oxgc) {
3548 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3549             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3550 0           my @tr = ($tr_variable,$2);
3551 0           while (not /\G \z/oxgc) {
3552 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3553 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3554 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3555 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3556 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3557 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3558             }
3559 0           die __FILE__, ": Transliteration replacement not terminated\n";
3560             }
3561             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3562 0           my @tr = ($tr_variable,$2);
3563 0           while (not /\G \z/oxgc) {
3564 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3565 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3566 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3567 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3568 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3569 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3570             }
3571 0           die __FILE__, ": Transliteration replacement not terminated\n";
3572             }
3573             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3574 0           my @tr = ($tr_variable,$2);
3575 0           while (not /\G \z/oxgc) {
3576 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3577 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3578 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3579 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3580 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3581 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3582             }
3583 0           die __FILE__, ": Transliteration replacement not terminated\n";
3584             }
3585             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3586 0           my @tr = ($tr_variable,$2);
3587 0           while (not /\G \z/oxgc) {
3588 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3589 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3590 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3591 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3592 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3593 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3594             }
3595 0           die __FILE__, ": Transliteration replacement not terminated\n";
3596             }
3597             # $1 $2 $3 $4 $5 $6
3598             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3599 0           my @tr = ($tr_variable,$2);
3600 0           return e_tr(@tr,'',$4,$6);
3601             }
3602             }
3603 0           die __FILE__, ": Transliteration pattern not terminated\n";
3604             }
3605             }
3606              
3607             # qq//
3608             elsif (/\G \b (qq) \b /oxgc) {
3609 0           my $ope = $1;
3610              
3611             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3612 0 0         if (/\G (\#) /oxgc) { # qq# #
3613 0           my $qq_string = '';
3614 0           while (not /\G \z/oxgc) {
3615 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3616 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3617 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3618 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3619             }
3620 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3621             }
3622              
3623             else {
3624 0           my $e = '';
3625 0           while (not /\G \z/oxgc) {
3626 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3627              
3628             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3629             elsif (/\G (\() /oxgc) { # qq ( )
3630 0           my $qq_string = '';
3631 0           local $nest = 1;
3632 0           while (not /\G \z/oxgc) {
3633 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3634 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3635 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3636             elsif (/\G (\)) /oxgc) {
3637 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3638 0           else { $qq_string .= $1; }
3639             }
3640 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3641             }
3642 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3643             }
3644              
3645             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3646             elsif (/\G (\{) /oxgc) { # qq { }
3647 0           my $qq_string = '';
3648 0           local $nest = 1;
3649 0           while (not /\G \z/oxgc) {
3650 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3651 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3652 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3653             elsif (/\G (\}) /oxgc) {
3654 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3655 0           else { $qq_string .= $1; }
3656             }
3657 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3658             }
3659 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3660             }
3661              
3662             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3663             elsif (/\G (\[) /oxgc) { # qq [ ]
3664 0           my $qq_string = '';
3665 0           local $nest = 1;
3666 0           while (not /\G \z/oxgc) {
3667 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3668 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3669 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3670             elsif (/\G (\]) /oxgc) {
3671 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3672 0           else { $qq_string .= $1; }
3673             }
3674 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3675             }
3676 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3677             }
3678              
3679             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3680             elsif (/\G (\<) /oxgc) { # qq < >
3681 0           my $qq_string = '';
3682 0           local $nest = 1;
3683 0           while (not /\G \z/oxgc) {
3684 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3685 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3686 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3687             elsif (/\G (\>) /oxgc) {
3688 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3689 0           else { $qq_string .= $1; }
3690             }
3691 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3692             }
3693 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3694             }
3695              
3696             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3697             elsif (/\G (\S) /oxgc) { # qq * *
3698 0           my $delimiter = $1;
3699 0           my $qq_string = '';
3700 0           while (not /\G \z/oxgc) {
3701 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3702 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3703 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3704 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3705             }
3706 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3707             }
3708             }
3709 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3710             }
3711             }
3712              
3713             # qr//
3714             elsif (/\G \b (qr) \b /oxgc) {
3715 0           my $ope = $1;
3716 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3717 0           return e_qr($ope,$1,$3,$2,$4);
3718             }
3719             else {
3720 0           my $e = '';
3721 0           while (not /\G \z/oxgc) {
3722 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3723 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3724 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3725 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3726 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3727 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3728 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3729 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3730             }
3731 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3732             }
3733             }
3734              
3735             # qw//
3736             elsif (/\G \b (qw) \b /oxgc) {
3737 0           my $ope = $1;
3738 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3739 0           return e_qw($ope,$1,$3,$2);
3740             }
3741             else {
3742 0           my $e = '';
3743 0           while (not /\G \z/oxgc) {
3744 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3745              
3746 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3747 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3748              
3749 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3750 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3751              
3752 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3753 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3754              
3755 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3756 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3757              
3758 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3759 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3760             }
3761 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3762             }
3763             }
3764              
3765             # qx//
3766             elsif (/\G \b (qx) \b /oxgc) {
3767 0           my $ope = $1;
3768 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3769 0           return e_qq($ope,$1,$3,$2);
3770             }
3771             else {
3772 0           my $e = '';
3773 0           while (not /\G \z/oxgc) {
3774 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3775 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3776 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3777 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3778 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3779 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3780 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3781             }
3782 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3783             }
3784             }
3785              
3786             # q//
3787             elsif (/\G \b (q) \b /oxgc) {
3788 0           my $ope = $1;
3789              
3790             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3791              
3792             # avoid "Error: Runtime exception" of perl version 5.005_03
3793             # (and so on)
3794              
3795 0 0         if (/\G (\#) /oxgc) { # q# #
3796 0           my $q_string = '';
3797 0           while (not /\G \z/oxgc) {
3798 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3799 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3800 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3801 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3802             }
3803 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3804             }
3805              
3806             else {
3807 0           my $e = '';
3808 0           while (not /\G \z/oxgc) {
3809 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3810              
3811             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3812             elsif (/\G (\() /oxgc) { # q ( )
3813 0           my $q_string = '';
3814 0           local $nest = 1;
3815 0           while (not /\G \z/oxgc) {
3816 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3817 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3818 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3819 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3820             elsif (/\G (\)) /oxgc) {
3821 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3822 0           else { $q_string .= $1; }
3823             }
3824 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3825             }
3826 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3827             }
3828              
3829             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3830             elsif (/\G (\{) /oxgc) { # q { }
3831 0           my $q_string = '';
3832 0           local $nest = 1;
3833 0           while (not /\G \z/oxgc) {
3834 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3835 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3836 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3837 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3838             elsif (/\G (\}) /oxgc) {
3839 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3840 0           else { $q_string .= $1; }
3841             }
3842 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3843             }
3844 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3845             }
3846              
3847             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3848             elsif (/\G (\[) /oxgc) { # q [ ]
3849 0           my $q_string = '';
3850 0           local $nest = 1;
3851 0           while (not /\G \z/oxgc) {
3852 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3853 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3854 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3855 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3856             elsif (/\G (\]) /oxgc) {
3857 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3858 0           else { $q_string .= $1; }
3859             }
3860 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3861             }
3862 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3863             }
3864              
3865             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3866             elsif (/\G (\<) /oxgc) { # q < >
3867 0           my $q_string = '';
3868 0           local $nest = 1;
3869 0           while (not /\G \z/oxgc) {
3870 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3871 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3872 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3873 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3874             elsif (/\G (\>) /oxgc) {
3875 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3876 0           else { $q_string .= $1; }
3877             }
3878 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3879             }
3880 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3881             }
3882              
3883             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3884             elsif (/\G (\S) /oxgc) { # q * *
3885 0           my $delimiter = $1;
3886 0           my $q_string = '';
3887 0           while (not /\G \z/oxgc) {
3888 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3889 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3890 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3891 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3892             }
3893 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3894             }
3895             }
3896 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3897             }
3898             }
3899              
3900             # m//
3901             elsif (/\G \b (m) \b /oxgc) {
3902 0           my $ope = $1;
3903 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3904 0           return e_qr($ope,$1,$3,$2,$4);
3905             }
3906             else {
3907 0           my $e = '';
3908 0           while (not /\G \z/oxgc) {
3909 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3910 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3911 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3912 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3913 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3914 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3915 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3916 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3917 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3918             }
3919 0           die __FILE__, ": Search pattern not terminated\n";
3920             }
3921             }
3922              
3923             # s///
3924              
3925             # about [cegimosxpradlunbB]* (/cg modifier)
3926             #
3927             # P.67 Pattern-Matching Operators
3928             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3929              
3930             elsif (/\G \b (s) \b /oxgc) {
3931 0           my $ope = $1;
3932              
3933             # $1 $2 $3 $4 $5 $6
3934 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3935 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3936             }
3937             else {
3938 0           my $e = '';
3939 0           while (not /\G \z/oxgc) {
3940 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3941             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3942 0           my @s = ($1,$2,$3);
3943 0           while (not /\G \z/oxgc) {
3944 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3945             # $1 $2 $3 $4
3946 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955             }
3956 0           die __FILE__, ": Substitution replacement not terminated\n";
3957             }
3958             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3959 0           my @s = ($1,$2,$3);
3960 0           while (not /\G \z/oxgc) {
3961 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3962             # $1 $2 $3 $4
3963 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972             }
3973 0           die __FILE__, ": Substitution replacement not terminated\n";
3974             }
3975             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3976 0           my @s = ($1,$2,$3);
3977 0           while (not /\G \z/oxgc) {
3978 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3979             # $1 $2 $3 $4
3980 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3985 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3986 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3987             }
3988 0           die __FILE__, ": Substitution replacement not terminated\n";
3989             }
3990             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3991 0           my @s = ($1,$2,$3);
3992 0           while (not /\G \z/oxgc) {
3993 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3994             # $1 $2 $3 $4
3995 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3997 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3998 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3999 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4000 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4001 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4002 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4003 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4004             }
4005 0           die __FILE__, ": Substitution replacement not terminated\n";
4006             }
4007             # $1 $2 $3 $4 $5 $6
4008             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4009 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4010             }
4011             # $1 $2 $3 $4 $5 $6
4012             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4013 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4014             }
4015             # $1 $2 $3 $4 $5 $6
4016             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4017 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4018             }
4019             # $1 $2 $3 $4 $5 $6
4020             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4021 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4022             }
4023             }
4024 0           die __FILE__, ": Substitution pattern not terminated\n";
4025             }
4026             }
4027              
4028             # require ignore module
4029 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4030 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4031 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4032              
4033             # use strict; --> use strict; no strict qw(refs);
4034 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4035 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4036 0           elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4037              
4038             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4039             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4040 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
4041 0           return "use $1; no strict qw(refs);";
4042             }
4043             else {
4044 0           return "use $1;";
4045             }
4046             }
4047             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4048 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4049 0           return "use $1; no strict qw(refs);";
4050             }
4051             else {
4052 0           return "use $1;";
4053             }
4054             }
4055              
4056             # ignore use module
4057 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4058 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4059 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4060              
4061             # ignore no module
4062 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4063 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4064 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4065              
4066             # use else
4067 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4068              
4069             # use else
4070 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4071              
4072             # ''
4073             elsif (/\G (?
4074 0           my $q_string = '';
4075 0           while (not /\G \z/oxgc) {
4076 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4077 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4078 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4079 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4080             }
4081 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4082             }
4083              
4084             # ""
4085             elsif (/\G (\") /oxgc) {
4086 0           my $qq_string = '';
4087 0           while (not /\G \z/oxgc) {
4088 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4089 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4090 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4091 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4092             }
4093 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4094             }
4095              
4096             # ``
4097             elsif (/\G (\`) /oxgc) {
4098 0           my $qx_string = '';
4099 0           while (not /\G \z/oxgc) {
4100 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4101 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4102 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4103 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4104             }
4105 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4106             }
4107              
4108             # // --- not divide operator (num / num), not defined-or
4109             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4110 0           my $regexp = '';
4111 0           while (not /\G \z/oxgc) {
4112 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4113 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4114 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4115 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4116             }
4117 0           die __FILE__, ": Search pattern not terminated\n";
4118             }
4119              
4120             # ?? --- not conditional operator (condition ? then : else)
4121             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4122 0           my $regexp = '';
4123 0           while (not /\G \z/oxgc) {
4124 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4125 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4126 0           elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4127 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4128             }
4129 0           die __FILE__, ": Search pattern not terminated\n";
4130             }
4131              
4132             # <<>> (a safer ARGV)
4133 0           elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4134              
4135             # << (bit shift) --- not here document
4136 0           elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4137              
4138             # <<'HEREDOC'
4139             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4140 0           $slash = 'm//';
4141 0           my $here_quote = $1;
4142 0           my $delimiter = $2;
4143              
4144             # get here document
4145 0 0         if ($here_script eq '') {
4146 0           $here_script = CORE::substr $_, pos $_;
4147 0           $here_script =~ s/.*?\n//oxm;
4148             }
4149 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4150 0           push @heredoc, $1 . qq{\n$delimiter\n};
4151 0           push @heredoc_delimiter, $delimiter;
4152             }
4153             else {
4154 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4155             }
4156 0           return $here_quote;
4157             }
4158              
4159             # <<\HEREDOC
4160              
4161             # P.66 2.6.6. "Here" Documents
4162             # in Chapter 2: Bits and Pieces
4163             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4164              
4165             # P.73 "Here" Documents
4166             # in Chapter 2: Bits and Pieces
4167             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4168              
4169             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4170 0           $slash = 'm//';
4171 0           my $here_quote = $1;
4172 0           my $delimiter = $2;
4173              
4174             # get here document
4175 0 0         if ($here_script eq '') {
4176 0           $here_script = CORE::substr $_, pos $_;
4177 0           $here_script =~ s/.*?\n//oxm;
4178             }
4179 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4180 0           push @heredoc, $1 . qq{\n$delimiter\n};
4181 0           push @heredoc_delimiter, $delimiter;
4182             }
4183             else {
4184 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4185             }
4186 0           return $here_quote;
4187             }
4188              
4189             # <<"HEREDOC"
4190             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4191 0           $slash = 'm//';
4192 0           my $here_quote = $1;
4193 0           my $delimiter = $2;
4194              
4195             # get here document
4196 0 0         if ($here_script eq '') {
4197 0           $here_script = CORE::substr $_, pos $_;
4198 0           $here_script =~ s/.*?\n//oxm;
4199             }
4200 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4201 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4202 0           push @heredoc_delimiter, $delimiter;
4203             }
4204             else {
4205 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4206             }
4207 0           return $here_quote;
4208             }
4209              
4210             # <
4211             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4212 0           $slash = 'm//';
4213 0           my $here_quote = $1;
4214 0           my $delimiter = $2;
4215              
4216             # get here document
4217 0 0         if ($here_script eq '') {
4218 0           $here_script = CORE::substr $_, pos $_;
4219 0           $here_script =~ s/.*?\n//oxm;
4220             }
4221 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4222 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4223 0           push @heredoc_delimiter, $delimiter;
4224             }
4225             else {
4226 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4227             }
4228 0           return $here_quote;
4229             }
4230              
4231             # <<`HEREDOC`
4232             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4233 0           $slash = 'm//';
4234 0           my $here_quote = $1;
4235 0           my $delimiter = $2;
4236              
4237             # get here document
4238 0 0         if ($here_script eq '') {
4239 0           $here_script = CORE::substr $_, pos $_;
4240 0           $here_script =~ s/.*?\n//oxm;
4241             }
4242 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4243 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4244 0           push @heredoc_delimiter, $delimiter;
4245             }
4246             else {
4247 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4248             }
4249 0           return $here_quote;
4250             }
4251              
4252             # <<= <=> <= < operator
4253             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4254 0           return $1;
4255             }
4256              
4257             #
4258             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4259 0           return $1;
4260             }
4261              
4262             # --- glob
4263              
4264             # avoid "Error: Runtime exception" of perl version 5.005_03
4265              
4266             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4267 0           return 'Elatin10::glob("' . $1 . '")';
4268             }
4269              
4270             # __DATA__
4271 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4272              
4273             # __END__
4274 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4275              
4276             # \cD Control-D
4277              
4278             # P.68 2.6.8. Other Literal Tokens
4279             # in Chapter 2: Bits and Pieces
4280             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4281              
4282             # P.76 Other Literal Tokens
4283             # in Chapter 2: Bits and Pieces
4284             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4285              
4286 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4287              
4288             # \cZ Control-Z
4289 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4290              
4291             # any operator before div
4292             elsif (/\G (
4293             -- | \+\+ |
4294             [\)\}\]]
4295              
4296 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4297              
4298             # yada-yada or triple-dot operator
4299             elsif (/\G (
4300             \.\.\.
4301              
4302 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4303              
4304             # any operator before m//
4305              
4306             # //, //= (defined-or)
4307              
4308             # P.164 Logical Operators
4309             # in Chapter 10: More Control Structures
4310             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4311              
4312             # P.119 C-Style Logical (Short-Circuit) Operators
4313             # in Chapter 3: Unary and Binary Operators
4314             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4315              
4316             # (and so on)
4317              
4318             # ~~
4319              
4320             # P.221 The Smart Match Operator
4321             # in Chapter 15: Smart Matching and given-when
4322             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4323              
4324             # P.112 Smartmatch Operator
4325             # in Chapter 3: Unary and Binary Operators
4326             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4327              
4328             # (and so on)
4329              
4330             elsif (/\G ((?>
4331              
4332             !~~ | !~ | != | ! |
4333             %= | % |
4334             &&= | && | &= | &\.= | &\. | & |
4335             -= | -> | - |
4336             :(?>\s*)= |
4337             : |
4338             <<>> |
4339             <<= | <=> | <= | < |
4340             == | => | =~ | = |
4341             >>= | >> | >= | > |
4342             \*\*= | \*\* | \*= | \* |
4343             \+= | \+ |
4344             \.\. | \.= | \. |
4345             \/\/= | \/\/ |
4346             \/= | \/ |
4347             \? |
4348             \\ |
4349             \^= | \^\.= | \^\. | \^ |
4350             \b x= |
4351             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4352             ~~ | ~\. | ~ |
4353             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4354             \b(?: print )\b |
4355              
4356             [,;\(\{\[]
4357              
4358 0           )) /oxgc) { $slash = 'm//'; return $1; }
  0            
4359              
4360             # other any character
4361 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4362              
4363             # system error
4364             else {
4365 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4366             }
4367             }
4368              
4369             # escape Latin-10 string
4370             sub e_string {
4371 0     0 0   my($string) = @_;
4372 0           my $e_string = '';
4373              
4374 0           local $slash = 'm//';
4375              
4376             # P.1024 Appendix W.10 Multibyte Processing
4377             # of ISBN 1-56592-224-7 CJKV Information Processing
4378             # (and so on)
4379              
4380 0           my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4381              
4382             # without { ... }
4383 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4384 0 0         if ($string !~ /<
4385 0           return $string;
4386             }
4387             }
4388              
4389             E_STRING_LOOP:
4390 0           while ($string !~ /\G \z/oxgc) {
4391 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4392             }
4393              
4394             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin10::PREMATCH()]}
4395 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4396 0           $e_string .= q{Elatin10::PREMATCH()};
4397 0           $slash = 'div';
4398             }
4399              
4400             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin10::MATCH()]}
4401             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4402 0           $e_string .= q{Elatin10::MATCH()};
4403 0           $slash = 'div';
4404             }
4405              
4406             # $', ${'} --> $', ${'}
4407             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4408 0           $e_string .= $1;
4409 0           $slash = 'div';
4410             }
4411              
4412             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin10::POSTMATCH()]}
4413             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4414 0           $e_string .= q{Elatin10::POSTMATCH()};
4415 0           $slash = 'div';
4416             }
4417              
4418             # bareword
4419             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4420 0           $e_string .= $1;
4421 0           $slash = 'div';
4422             }
4423              
4424             # $0 --> $0
4425             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4426 0           $e_string .= $1;
4427 0           $slash = 'div';
4428             }
4429             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4430 0           $e_string .= $1;
4431 0           $slash = 'div';
4432             }
4433              
4434             # $$ --> $$
4435             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4436 0           $e_string .= $1;
4437 0           $slash = 'div';
4438             }
4439              
4440             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4441             # $1, $2, $3 --> $1, $2, $3 otherwise
4442             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4443 0           $e_string .= e_capture($1);
4444 0           $slash = 'div';
4445             }
4446             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4447 0           $e_string .= e_capture($1);
4448 0           $slash = 'div';
4449             }
4450              
4451             # $$foo[ ... ] --> $ $foo->[ ... ]
4452             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4453 0           $e_string .= e_capture($1.'->'.$2);
4454 0           $slash = 'div';
4455             }
4456              
4457             # $$foo{ ... } --> $ $foo->{ ... }
4458             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4459 0           $e_string .= e_capture($1.'->'.$2);
4460 0           $slash = 'div';
4461             }
4462              
4463             # $$foo
4464             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4465 0           $e_string .= e_capture($1);
4466 0           $slash = 'div';
4467             }
4468              
4469             # ${ foo }
4470             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4471 0           $e_string .= '${' . $1 . '}';
4472 0           $slash = 'div';
4473             }
4474              
4475             # ${ ... }
4476             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4477 0           $e_string .= e_capture($1);
4478 0           $slash = 'div';
4479             }
4480              
4481             # variable or function
4482             # $ @ % & * $ #
4483             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) {
4484 0           $e_string .= $1;
4485 0           $slash = 'div';
4486             }
4487             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4488             # $ @ # \ ' " / ? ( ) [ ] < >
4489             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4490 0           $e_string .= $1;
4491 0           $slash = 'div';
4492             }
4493              
4494             # subroutines of package Elatin10
4495 0           elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4496 0           elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4497 0           elsif ($string =~ /\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4498 0           elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0            
4499 0           elsif ($string =~ /\G \b Latin10::eval \b /oxgc) { $e_string .= 'eval Latin10::escape'; $slash = 'm//'; }
  0            
4500 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4501 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin10::chop'; $slash = 'm//'; }
  0            
4502 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4503 0           elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0            
4504 0           elsif ($string =~ /\G \b Latin10::index \b /oxgc) { $e_string .= 'Latin10::index'; $slash = 'm//'; }
  0            
4505 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin10::index'; $slash = 'm//'; }
  0            
4506 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4507 0           elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0            
4508 0           elsif ($string =~ /\G \b Latin10::rindex \b /oxgc) { $e_string .= 'Latin10::rindex'; $slash = 'm//'; }
  0            
4509 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin10::rindex'; $slash = 'm//'; }
  0            
4510 0           elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lc'; $slash = 'm//'; }
  0            
4511 0           elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lcfirst'; $slash = 'm//'; }
  0            
4512 0           elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::uc'; $slash = 'm//'; }
  0            
4513 0           elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::ucfirst'; $slash = 'm//'; }
  0            
4514 0           elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::fc'; $slash = 'm//'; }
  0            
4515              
4516             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4517 0           elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4518 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4519 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4520 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4521 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4522 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4523 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            
4524              
4525 0           elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4526 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4527 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4528 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4529 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4530 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4531 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4532              
4533             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4534 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4535 0           elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4536 0           elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4537 0           elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4538              
4539 0           elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4540 0           elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4541 0           elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::chr'; $slash = 'm//'; }
  0            
4542 0           elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4543 0           elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4544 0           elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::glob'; $slash = 'm//'; }
  0            
4545 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin10::lc_'; $slash = 'm//'; }
  0            
4546 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin10::lcfirst_'; $slash = 'm//'; }
  0            
4547 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin10::uc_'; $slash = 'm//'; }
  0            
4548 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin10::ucfirst_'; $slash = 'm//'; }
  0            
4549 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin10::fc_'; $slash = 'm//'; }
  0            
4550 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4551              
4552 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4553 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4554 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin10::chr_'; $slash = 'm//'; }
  0            
4555 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4556 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4557 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin10::glob_'; $slash = 'm//'; }
  0            
4558 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4559 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4560             # split
4561             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4562 0           $slash = 'm//';
4563              
4564 0           my $e = '';
4565 0           while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4566 0           $e .= $1;
4567             }
4568              
4569             # end of split
4570 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4571              
4572             # split scalar value
4573 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin10::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4574              
4575             # split literal space
4576 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4577 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4578 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4579 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4580 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4581 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4582 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4583 0           elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4584 0           elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4585 0           elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4586 0           elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4587 0           elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4588 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4589 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4590              
4591             # split qq//
4592             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4593 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0            
  0            
4594             else {
4595 0           while ($string !~ /\G \z/oxgc) {
4596 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4597 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4598 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4599 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4600 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4601 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4602 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0            
4603             }
4604 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4605             }
4606             }
4607              
4608             # split qr//
4609             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4610 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
4611             else {
4612 0           while ($string !~ /\G \z/oxgc) {
4613 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4614 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4615 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4616 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4617 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4618 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            
4619 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4620 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0            
4621             }
4622 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4623             }
4624             }
4625              
4626             # split q//
4627             elsif ($string =~ /\G \b (q) \b /oxgc) {
4628 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0            
  0            
4629             else {
4630 0           while ($string !~ /\G \z/oxgc) {
4631 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4632 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4633 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4634 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4635 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4636 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4637 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
  0            
4638             }
4639 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4640             }
4641             }
4642              
4643             # split m//
4644             elsif ($string =~ /\G \b (m) \b /oxgc) {
4645 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0            
  0            
4646             else {
4647 0           while ($string !~ /\G \z/oxgc) {
4648 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4649 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            
4650 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            
4651 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            
4652 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            
4653 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            
4654 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4655 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0            
4656             }
4657 0           die __FILE__, ": Search pattern not terminated\n";
4658             }
4659             }
4660              
4661             # split ''
4662             elsif ($string =~ /\G (\') /oxgc) {
4663 0           my $q_string = '';
4664 0           while ($string !~ /\G \z/oxgc) {
4665 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4666 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4667 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4668 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4669             }
4670 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4671             }
4672              
4673             # split ""
4674             elsif ($string =~ /\G (\") /oxgc) {
4675 0           my $qq_string = '';
4676 0           while ($string !~ /\G \z/oxgc) {
4677 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4678 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4679 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4680 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4681             }
4682 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4683             }
4684              
4685             # split //
4686             elsif ($string =~ /\G (\/) /oxgc) {
4687 0           my $regexp = '';
4688 0           while ($string !~ /\G \z/oxgc) {
4689 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4690 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4691 0           elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4692 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4693             }
4694 0           die __FILE__, ": Search pattern not terminated\n";
4695             }
4696             }
4697              
4698             # qq//
4699             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4700 0           my $ope = $1;
4701 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4702 0           $e_string .= e_qq($ope,$1,$3,$2);
4703             }
4704             else {
4705 0           my $e = '';
4706 0           while ($string !~ /\G \z/oxgc) {
4707 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4708 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4709 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4710 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4711 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4712 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4713             }
4714 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4715             }
4716             }
4717              
4718             # qx//
4719             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4720 0           my $ope = $1;
4721 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4722 0           $e_string .= e_qq($ope,$1,$3,$2);
4723             }
4724             else {
4725 0           my $e = '';
4726 0           while ($string !~ /\G \z/oxgc) {
4727 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4728 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4729 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4730 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4731 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4732 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4733 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4734             }
4735 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4736             }
4737             }
4738              
4739             # q//
4740             elsif ($string =~ /\G \b (q) \b /oxgc) {
4741 0           my $ope = $1;
4742 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4743 0           $e_string .= e_q($ope,$1,$3,$2);
4744             }
4745             else {
4746 0           my $e = '';
4747 0           while ($string !~ /\G \z/oxgc) {
4748 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4749 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4750 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4751 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4752 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4753 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0            
4754             }
4755 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4756             }
4757             }
4758              
4759             # ''
4760 0           elsif ($string =~ /\G (?
4761              
4762             # ""
4763 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4764              
4765             # ``
4766 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4767              
4768             # <<>> (a safer ARGV)
4769 0           elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4770              
4771             # <<= <=> <= < operator
4772 0           elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4773              
4774             #
4775 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4776              
4777             # --- glob
4778             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4779 0           $e_string .= 'Elatin10::glob("' . $1 . '")';
4780             }
4781              
4782             # << (bit shift) --- not here document
4783 0           elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4784              
4785             # <<'HEREDOC'
4786             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4787 0           $slash = 'm//';
4788 0           my $here_quote = $1;
4789 0           my $delimiter = $2;
4790              
4791             # get here document
4792 0 0         if ($here_script eq '') {
4793 0           $here_script = CORE::substr $_, pos $_;
4794 0           $here_script =~ s/.*?\n//oxm;
4795             }
4796 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4797 0           push @heredoc, $1 . qq{\n$delimiter\n};
4798 0           push @heredoc_delimiter, $delimiter;
4799             }
4800             else {
4801 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4802             }
4803 0           $e_string .= $here_quote;
4804             }
4805              
4806             # <<\HEREDOC
4807             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4808 0           $slash = 'm//';
4809 0           my $here_quote = $1;
4810 0           my $delimiter = $2;
4811              
4812             # get here document
4813 0 0         if ($here_script eq '') {
4814 0           $here_script = CORE::substr $_, pos $_;
4815 0           $here_script =~ s/.*?\n//oxm;
4816             }
4817 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4818 0           push @heredoc, $1 . qq{\n$delimiter\n};
4819 0           push @heredoc_delimiter, $delimiter;
4820             }
4821             else {
4822 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4823             }
4824 0           $e_string .= $here_quote;
4825             }
4826              
4827             # <<"HEREDOC"
4828             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4829 0           $slash = 'm//';
4830 0           my $here_quote = $1;
4831 0           my $delimiter = $2;
4832              
4833             # get here document
4834 0 0         if ($here_script eq '') {
4835 0           $here_script = CORE::substr $_, pos $_;
4836 0           $here_script =~ s/.*?\n//oxm;
4837             }
4838 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4839 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4840 0           push @heredoc_delimiter, $delimiter;
4841             }
4842             else {
4843 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4844             }
4845 0           $e_string .= $here_quote;
4846             }
4847              
4848             # <
4849             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4850 0           $slash = 'm//';
4851 0           my $here_quote = $1;
4852 0           my $delimiter = $2;
4853              
4854             # get here document
4855 0 0         if ($here_script eq '') {
4856 0           $here_script = CORE::substr $_, pos $_;
4857 0           $here_script =~ s/.*?\n//oxm;
4858             }
4859 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4860 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4861 0           push @heredoc_delimiter, $delimiter;
4862             }
4863             else {
4864 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4865             }
4866 0           $e_string .= $here_quote;
4867             }
4868              
4869             # <<`HEREDOC`
4870             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4871 0           $slash = 'm//';
4872 0           my $here_quote = $1;
4873 0           my $delimiter = $2;
4874              
4875             # get here document
4876 0 0         if ($here_script eq '') {
4877 0           $here_script = CORE::substr $_, pos $_;
4878 0           $here_script =~ s/.*?\n//oxm;
4879             }
4880 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4881 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4882 0           push @heredoc_delimiter, $delimiter;
4883             }
4884             else {
4885 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4886             }
4887 0           $e_string .= $here_quote;
4888             }
4889              
4890             # any operator before div
4891             elsif ($string =~ /\G (
4892             -- | \+\+ |
4893             [\)\}\]]
4894              
4895 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4896              
4897             # yada-yada or triple-dot operator
4898             elsif ($string =~ /\G (
4899             \.\.\.
4900              
4901 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4902              
4903             # any operator before m//
4904             elsif ($string =~ /\G ((?>
4905              
4906             !~~ | !~ | != | ! |
4907             %= | % |
4908             &&= | && | &= | &\.= | &\. | & |
4909             -= | -> | - |
4910             :(?>\s*)= |
4911             : |
4912             <<>> |
4913             <<= | <=> | <= | < |
4914             == | => | =~ | = |
4915             >>= | >> | >= | > |
4916             \*\*= | \*\* | \*= | \* |
4917             \+= | \+ |
4918             \.\. | \.= | \. |
4919             \/\/= | \/\/ |
4920             \/= | \/ |
4921             \? |
4922             \\ |
4923             \^= | \^\.= | \^\. | \^ |
4924             \b x= |
4925             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4926             ~~ | ~\. | ~ |
4927             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4928             \b(?: print )\b |
4929              
4930             [,;\(\{\[]
4931              
4932 0           )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4933              
4934             # other any character
4935 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4936              
4937             # system error
4938             else {
4939 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4940             }
4941             }
4942              
4943 0           return $e_string;
4944             }
4945              
4946             #
4947             # character class
4948             #
4949             sub character_class {
4950 0     0 0   my($char,$modifier) = @_;
4951              
4952 0 0         if ($char eq '.') {
4953 0 0         if ($modifier =~ /s/) {
4954 0           return '${Elatin10::dot_s}';
4955             }
4956             else {
4957 0           return '${Elatin10::dot}';
4958             }
4959             }
4960             else {
4961 0           return Elatin10::classic_character_class($char);
4962             }
4963             }
4964              
4965             #
4966             # escape capture ($1, $2, $3, ...)
4967             #
4968             sub e_capture {
4969              
4970 0     0 0   return join '', '${', $_[0], '}';
4971             }
4972              
4973             #
4974             # escape transliteration (tr/// or y///)
4975             #
4976             sub e_tr {
4977 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4978 0           my $e_tr = '';
4979 0   0       $modifier ||= '';
4980              
4981 0           $slash = 'div';
4982              
4983             # quote character class 1
4984 0           $charclass = q_tr($charclass);
4985              
4986             # quote character class 2
4987 0           $charclass2 = q_tr($charclass2);
4988              
4989             # /b /B modifier
4990 0 0         if ($modifier =~ tr/bB//d) {
4991 0 0         if ($variable eq '') {
4992 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4993             }
4994             else {
4995 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4996             }
4997             }
4998             else {
4999 0 0         if ($variable eq '') {
5000 0           $e_tr = qq{Elatin10::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5001             }
5002             else {
5003 0           $e_tr = qq{Elatin10::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5004             }
5005             }
5006              
5007             # clear tr/// variable
5008 0           $tr_variable = '';
5009 0           $bind_operator = '';
5010              
5011 0           return $e_tr;
5012             }
5013              
5014             #
5015             # quote for escape transliteration (tr/// or y///)
5016             #
5017             sub q_tr {
5018 0     0 0   my($charclass) = @_;
5019              
5020             # quote character class
5021 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5022 0           return e_q('', "'", "'", $charclass); # --> q' '
5023             }
5024             elsif ($charclass !~ /\//oxms) {
5025 0           return e_q('q', '/', '/', $charclass); # --> q/ /
5026             }
5027             elsif ($charclass !~ /\#/oxms) {
5028 0           return e_q('q', '#', '#', $charclass); # --> q# #
5029             }
5030             elsif ($charclass !~ /[\<\>]/oxms) {
5031 0           return e_q('q', '<', '>', $charclass); # --> q< >
5032             }
5033             elsif ($charclass !~ /[\(\)]/oxms) {
5034 0           return e_q('q', '(', ')', $charclass); # --> q( )
5035             }
5036             elsif ($charclass !~ /[\{\}]/oxms) {
5037 0           return e_q('q', '{', '}', $charclass); # --> q{ }
5038             }
5039             else {
5040 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5041 0 0         if ($charclass !~ /\Q$char\E/xms) {
5042 0           return e_q('q', $char, $char, $charclass);
5043             }
5044             }
5045             }
5046              
5047 0           return e_q('q', '{', '}', $charclass);
5048             }
5049              
5050             #
5051             # escape q string (q//, '')
5052             #
5053             sub e_q {
5054 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5055              
5056 0           $slash = 'div';
5057              
5058 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5059             }
5060              
5061             #
5062             # escape qq string (qq//, "", qx//, ``)
5063             #
5064             sub e_qq {
5065 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5066              
5067 0           $slash = 'div';
5068              
5069 0           my $left_e = 0;
5070 0           my $right_e = 0;
5071              
5072             # split regexp
5073 0           my @char = $string =~ /\G((?>
5074             [^\\\$] |
5075             \\x\{ (?>[0-9A-Fa-f]+) \} |
5076             \\o\{ (?>[0-7]+) \} |
5077             \\N\{ (?>[^0-9\}][^\}]*) \} |
5078             \\ $q_char |
5079             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5080             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5081             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5082             \$ (?>\s* [0-9]+) |
5083             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5084             \$ \$ (?![\w\{]) |
5085             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5086             $q_char
5087             ))/oxmsg;
5088              
5089 0           for (my $i=0; $i <= $#char; $i++) {
5090              
5091             # "\L\u" --> "\u\L"
5092 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5093 0           @char[$i,$i+1] = @char[$i+1,$i];
5094             }
5095              
5096             # "\U\l" --> "\l\U"
5097             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5098 0           @char[$i,$i+1] = @char[$i+1,$i];
5099             }
5100              
5101             # octal escape sequence
5102             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5103 0           $char[$i] = Elatin10::octchr($1);
5104             }
5105              
5106             # hexadecimal escape sequence
5107             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5108 0           $char[$i] = Elatin10::hexchr($1);
5109             }
5110              
5111             # \N{CHARNAME} --> N{CHARNAME}
5112             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5113 0           $char[$i] = $1;
5114             }
5115              
5116 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5117             }
5118              
5119             # \F
5120             #
5121             # P.69 Table 2-6. Translation escapes
5122             # in Chapter 2: Bits and Pieces
5123             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5124             # (and so on)
5125              
5126             # \u \l \U \L \F \Q \E
5127 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5128 0 0         if ($right_e < $left_e) {
5129 0           $char[$i] = '\\' . $char[$i];
5130             }
5131             }
5132             elsif ($char[$i] eq '\u') {
5133              
5134             # "STRING @{[ LIST EXPR ]} MORE STRING"
5135              
5136             # P.257 Other Tricks You Can Do with Hard References
5137             # in Chapter 8: References
5138             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5139              
5140             # P.353 Other Tricks You Can Do with Hard References
5141             # in Chapter 8: References
5142             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5143              
5144             # (and so on)
5145              
5146 0           $char[$i] = '@{[Elatin10::ucfirst qq<';
5147 0           $left_e++;
5148             }
5149             elsif ($char[$i] eq '\l') {
5150 0           $char[$i] = '@{[Elatin10::lcfirst qq<';
5151 0           $left_e++;
5152             }
5153             elsif ($char[$i] eq '\U') {
5154 0           $char[$i] = '@{[Elatin10::uc qq<';
5155 0           $left_e++;
5156             }
5157             elsif ($char[$i] eq '\L') {
5158 0           $char[$i] = '@{[Elatin10::lc qq<';
5159 0           $left_e++;
5160             }
5161             elsif ($char[$i] eq '\F') {
5162 0           $char[$i] = '@{[Elatin10::fc qq<';
5163 0           $left_e++;
5164             }
5165             elsif ($char[$i] eq '\Q') {
5166 0           $char[$i] = '@{[CORE::quotemeta qq<';
5167 0           $left_e++;
5168             }
5169             elsif ($char[$i] eq '\E') {
5170 0 0         if ($right_e < $left_e) {
5171 0           $char[$i] = '>]}';
5172 0           $right_e++;
5173             }
5174             else {
5175 0           $char[$i] = '';
5176             }
5177             }
5178             elsif ($char[$i] eq '\Q') {
5179 0           while (1) {
5180 0 0         if (++$i > $#char) {
5181 0           last;
5182             }
5183 0 0         if ($char[$i] eq '\E') {
5184 0           last;
5185             }
5186             }
5187             }
5188             elsif ($char[$i] eq '\E') {
5189             }
5190              
5191             # $0 --> $0
5192             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5193             }
5194             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5195             }
5196              
5197             # $$ --> $$
5198             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5199             }
5200              
5201             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5202             # $1, $2, $3 --> $1, $2, $3 otherwise
5203             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5204 0           $char[$i] = e_capture($1);
5205             }
5206             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5207 0           $char[$i] = e_capture($1);
5208             }
5209              
5210             # $$foo[ ... ] --> $ $foo->[ ... ]
5211             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5212 0           $char[$i] = e_capture($1.'->'.$2);
5213             }
5214              
5215             # $$foo{ ... } --> $ $foo->{ ... }
5216             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5217 0           $char[$i] = e_capture($1.'->'.$2);
5218             }
5219              
5220             # $$foo
5221             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5222 0           $char[$i] = e_capture($1);
5223             }
5224              
5225             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5226             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5227 0           $char[$i] = '@{[Elatin10::PREMATCH()]}';
5228             }
5229              
5230             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5231             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5232 0           $char[$i] = '@{[Elatin10::MATCH()]}';
5233             }
5234              
5235             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5236             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5237 0           $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5238             }
5239              
5240             # ${ foo } --> ${ foo }
5241             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5242             }
5243              
5244             # ${ ... }
5245             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5246 0           $char[$i] = e_capture($1);
5247             }
5248             }
5249              
5250             # return string
5251 0 0         if ($left_e > $right_e) {
5252 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5253             }
5254 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5255             }
5256              
5257             #
5258             # escape qw string (qw//)
5259             #
5260             sub e_qw {
5261 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5262              
5263 0           $slash = 'div';
5264              
5265             # choice again delimiter
5266 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5267 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5268 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5269             }
5270             elsif (not $octet{')'}) {
5271 0           return join '', $ope, '(', $string, ')';
5272             }
5273             elsif (not $octet{'}'}) {
5274 0           return join '', $ope, '{', $string, '}';
5275             }
5276             elsif (not $octet{']'}) {
5277 0           return join '', $ope, '[', $string, ']';
5278             }
5279             elsif (not $octet{'>'}) {
5280 0           return join '', $ope, '<', $string, '>';
5281             }
5282             else {
5283 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5284 0 0         if (not $octet{$char}) {
5285 0           return join '', $ope, $char, $string, $char;
5286             }
5287             }
5288             }
5289              
5290             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5291 0           my @string = CORE::split(/\s+/, $string);
5292 0           for my $string (@string) {
5293 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5294 0           for my $octet (@octet) {
5295 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5296 0           $octet = '\\' . $1;
5297             }
5298             }
5299 0           $string = join '', @octet;
5300             }
5301 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5302             }
5303              
5304             #
5305             # escape here document (<<"HEREDOC", <
5306             #
5307             sub e_heredoc {
5308 0     0 0   my($string) = @_;
5309              
5310 0           $slash = 'm//';
5311              
5312 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5313              
5314 0           my $left_e = 0;
5315 0           my $right_e = 0;
5316              
5317             # split regexp
5318 0           my @char = $string =~ /\G((?>
5319             [^\\\$] |
5320             \\x\{ (?>[0-9A-Fa-f]+) \} |
5321             \\o\{ (?>[0-7]+) \} |
5322             \\N\{ (?>[^0-9\}][^\}]*) \} |
5323             \\ $q_char |
5324             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5325             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5326             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5327             \$ (?>\s* [0-9]+) |
5328             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5329             \$ \$ (?![\w\{]) |
5330             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5331             $q_char
5332             ))/oxmsg;
5333              
5334 0           for (my $i=0; $i <= $#char; $i++) {
5335              
5336             # "\L\u" --> "\u\L"
5337 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5338 0           @char[$i,$i+1] = @char[$i+1,$i];
5339             }
5340              
5341             # "\U\l" --> "\l\U"
5342             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5343 0           @char[$i,$i+1] = @char[$i+1,$i];
5344             }
5345              
5346             # octal escape sequence
5347             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5348 0           $char[$i] = Elatin10::octchr($1);
5349             }
5350              
5351             # hexadecimal escape sequence
5352             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5353 0           $char[$i] = Elatin10::hexchr($1);
5354             }
5355              
5356             # \N{CHARNAME} --> N{CHARNAME}
5357             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5358 0           $char[$i] = $1;
5359             }
5360              
5361 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5362             }
5363              
5364             # \u \l \U \L \F \Q \E
5365 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5366 0 0         if ($right_e < $left_e) {
5367 0           $char[$i] = '\\' . $char[$i];
5368             }
5369             }
5370             elsif ($char[$i] eq '\u') {
5371 0           $char[$i] = '@{[Elatin10::ucfirst qq<';
5372 0           $left_e++;
5373             }
5374             elsif ($char[$i] eq '\l') {
5375 0           $char[$i] = '@{[Elatin10::lcfirst qq<';
5376 0           $left_e++;
5377             }
5378             elsif ($char[$i] eq '\U') {
5379 0           $char[$i] = '@{[Elatin10::uc qq<';
5380 0           $left_e++;
5381             }
5382             elsif ($char[$i] eq '\L') {
5383 0           $char[$i] = '@{[Elatin10::lc qq<';
5384 0           $left_e++;
5385             }
5386             elsif ($char[$i] eq '\F') {
5387 0           $char[$i] = '@{[Elatin10::fc qq<';
5388 0           $left_e++;
5389             }
5390             elsif ($char[$i] eq '\Q') {
5391 0           $char[$i] = '@{[CORE::quotemeta qq<';
5392 0           $left_e++;
5393             }
5394             elsif ($char[$i] eq '\E') {
5395 0 0         if ($right_e < $left_e) {
5396 0           $char[$i] = '>]}';
5397 0           $right_e++;
5398             }
5399             else {
5400 0           $char[$i] = '';
5401             }
5402             }
5403             elsif ($char[$i] eq '\Q') {
5404 0           while (1) {
5405 0 0         if (++$i > $#char) {
5406 0           last;
5407             }
5408 0 0         if ($char[$i] eq '\E') {
5409 0           last;
5410             }
5411             }
5412             }
5413             elsif ($char[$i] eq '\E') {
5414             }
5415              
5416             # $0 --> $0
5417             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5418             }
5419             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5420             }
5421              
5422             # $$ --> $$
5423             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5424             }
5425              
5426             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5427             # $1, $2, $3 --> $1, $2, $3 otherwise
5428             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5429 0           $char[$i] = e_capture($1);
5430             }
5431             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5432 0           $char[$i] = e_capture($1);
5433             }
5434              
5435             # $$foo[ ... ] --> $ $foo->[ ... ]
5436             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5437 0           $char[$i] = e_capture($1.'->'.$2);
5438             }
5439              
5440             # $$foo{ ... } --> $ $foo->{ ... }
5441             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5442 0           $char[$i] = e_capture($1.'->'.$2);
5443             }
5444              
5445             # $$foo
5446             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5447 0           $char[$i] = e_capture($1);
5448             }
5449              
5450             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5451             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5452 0           $char[$i] = '@{[Elatin10::PREMATCH()]}';
5453             }
5454              
5455             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5456             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5457 0           $char[$i] = '@{[Elatin10::MATCH()]}';
5458             }
5459              
5460             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5461             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5462 0           $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5463             }
5464              
5465             # ${ foo } --> ${ foo }
5466             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5467             }
5468              
5469             # ${ ... }
5470             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5471 0           $char[$i] = e_capture($1);
5472             }
5473             }
5474              
5475             # return string
5476 0 0         if ($left_e > $right_e) {
5477 0           return join '', @char, '>]}' x ($left_e - $right_e);
5478             }
5479 0           return join '', @char;
5480             }
5481              
5482             #
5483             # escape regexp (m//, qr//)
5484             #
5485             sub e_qr {
5486 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5487 0   0       $modifier ||= '';
5488              
5489 0           $modifier =~ tr/p//d;
5490 0 0         if ($modifier =~ /([adlu])/oxms) {
5491 0           my $line = 0;
5492 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5493 0 0         if ($filename ne __FILE__) {
5494 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5495 0           last;
5496             }
5497             }
5498 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5499             }
5500              
5501 0           $slash = 'div';
5502              
5503             # literal null string pattern
5504 0 0         if ($string eq '') {
    0          
5505 0           $modifier =~ tr/bB//d;
5506 0           $modifier =~ tr/i//d;
5507 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5508             }
5509              
5510             # /b /B modifier
5511             elsif ($modifier =~ tr/bB//d) {
5512              
5513             # choice again delimiter
5514 0 0         if ($delimiter =~ / [\@:] /oxms) {
5515 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5516 0           my %octet = map {$_ => 1} @char;
  0            
5517 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5518 0           $delimiter = '(';
5519 0           $end_delimiter = ')';
5520             }
5521             elsif (not $octet{'}'}) {
5522 0           $delimiter = '{';
5523 0           $end_delimiter = '}';
5524             }
5525             elsif (not $octet{']'}) {
5526 0           $delimiter = '[';
5527 0           $end_delimiter = ']';
5528             }
5529             elsif (not $octet{'>'}) {
5530 0           $delimiter = '<';
5531 0           $end_delimiter = '>';
5532             }
5533             else {
5534 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5535 0 0         if (not $octet{$char}) {
5536 0           $delimiter = $char;
5537 0           $end_delimiter = $char;
5538 0           last;
5539             }
5540             }
5541             }
5542             }
5543              
5544 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5545 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5546             }
5547             else {
5548 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5549             }
5550             }
5551              
5552 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5553 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5554              
5555             # split regexp
5556 0           my @char = $string =~ /\G((?>
5557             [^\\\$\@\[\(] |
5558             \\x (?>[0-9A-Fa-f]{1,2}) |
5559             \\ (?>[0-7]{2,3}) |
5560             \\c [\x40-\x5F] |
5561             \\x\{ (?>[0-9A-Fa-f]+) \} |
5562             \\o\{ (?>[0-7]+) \} |
5563             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5564             \\ $q_char |
5565             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5566             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5567             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5568             [\$\@] $qq_variable |
5569             \$ (?>\s* [0-9]+) |
5570             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5571             \$ \$ (?![\w\{]) |
5572             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5573             \[\^ |
5574             \[\: (?>[a-z]+) :\] |
5575             \[\:\^ (?>[a-z]+) :\] |
5576             \(\? |
5577             $q_char
5578             ))/oxmsg;
5579              
5580             # choice again delimiter
5581 0 0         if ($delimiter =~ / [\@:] /oxms) {
5582 0           my %octet = map {$_ => 1} @char;
  0            
5583 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5584 0           $delimiter = '(';
5585 0           $end_delimiter = ')';
5586             }
5587             elsif (not $octet{'}'}) {
5588 0           $delimiter = '{';
5589 0           $end_delimiter = '}';
5590             }
5591             elsif (not $octet{']'}) {
5592 0           $delimiter = '[';
5593 0           $end_delimiter = ']';
5594             }
5595             elsif (not $octet{'>'}) {
5596 0           $delimiter = '<';
5597 0           $end_delimiter = '>';
5598             }
5599             else {
5600 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5601 0 0         if (not $octet{$char}) {
5602 0           $delimiter = $char;
5603 0           $end_delimiter = $char;
5604 0           last;
5605             }
5606             }
5607             }
5608             }
5609              
5610 0           my $left_e = 0;
5611 0           my $right_e = 0;
5612 0           for (my $i=0; $i <= $#char; $i++) {
5613              
5614             # "\L\u" --> "\u\L"
5615 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
5616 0           @char[$i,$i+1] = @char[$i+1,$i];
5617             }
5618              
5619             # "\U\l" --> "\l\U"
5620             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5621 0           @char[$i,$i+1] = @char[$i+1,$i];
5622             }
5623              
5624             # octal escape sequence
5625             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5626 0           $char[$i] = Elatin10::octchr($1);
5627             }
5628              
5629             # hexadecimal escape sequence
5630             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5631 0           $char[$i] = Elatin10::hexchr($1);
5632             }
5633              
5634             # \b{...} --> b\{...}
5635             # \B{...} --> B\{...}
5636             # \N{CHARNAME} --> N\{CHARNAME}
5637             # \p{PROPERTY} --> p\{PROPERTY}
5638             # \P{PROPERTY} --> P\{PROPERTY}
5639             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5640 0           $char[$i] = $1 . '\\' . $2;
5641             }
5642              
5643             # \p, \P, \X --> p, P, X
5644             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5645 0           $char[$i] = $1;
5646             }
5647              
5648 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5649             }
5650              
5651             # join separated multiple-octet
5652 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5653 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
5654 0           $char[$i] .= join '', splice @char, $i+1, 3;
5655             }
5656             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)) {
5657 0           $char[$i] .= join '', splice @char, $i+1, 2;
5658             }
5659             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)) {
5660 0           $char[$i] .= join '', splice @char, $i+1, 1;
5661             }
5662             }
5663              
5664             # open character class [...]
5665             elsif ($char[$i] eq '[') {
5666 0           my $left = $i;
5667              
5668             # [] make die "Unmatched [] in regexp ...\n"
5669             # (and so on)
5670              
5671 0 0         if ($char[$i+1] eq ']') {
5672 0           $i++;
5673             }
5674              
5675 0           while (1) {
5676 0 0         if (++$i > $#char) {
5677 0           die __FILE__, ": Unmatched [] in regexp\n";
5678             }
5679 0 0         if ($char[$i] eq ']') {
5680 0           my $right = $i;
5681              
5682             # [...]
5683 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5684 0           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);
  0            
5685             }
5686             else {
5687 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5688             }
5689              
5690 0           $i = $left;
5691 0           last;
5692             }
5693             }
5694             }
5695              
5696             # open character class [^...]
5697             elsif ($char[$i] eq '[^') {
5698 0           my $left = $i;
5699              
5700             # [^] make die "Unmatched [] in regexp ...\n"
5701             # (and so on)
5702              
5703 0 0         if ($char[$i+1] eq ']') {
5704 0           $i++;
5705             }
5706              
5707 0           while (1) {
5708 0 0         if (++$i > $#char) {
5709 0           die __FILE__, ": Unmatched [] in regexp\n";
5710             }
5711 0 0         if ($char[$i] eq ']') {
5712 0           my $right = $i;
5713              
5714             # [^...]
5715 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5716 0           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);
  0            
5717             }
5718             else {
5719 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5720             }
5721              
5722 0           $i = $left;
5723 0           last;
5724             }
5725             }
5726             }
5727              
5728             # rewrite character class or escape character
5729             elsif (my $char = character_class($char[$i],$modifier)) {
5730 0           $char[$i] = $char;
5731             }
5732              
5733             # /i modifier
5734             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
5735 0 0         if (CORE::length(Elatin10::fc($char[$i])) == 1) {
5736 0           $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
5737             }
5738             else {
5739 0           $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
5740             }
5741             }
5742              
5743             # \u \l \U \L \F \Q \E
5744             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5745 0 0         if ($right_e < $left_e) {
5746 0           $char[$i] = '\\' . $char[$i];
5747             }
5748             }
5749             elsif ($char[$i] eq '\u') {
5750 0           $char[$i] = '@{[Elatin10::ucfirst qq<';
5751 0           $left_e++;
5752             }
5753             elsif ($char[$i] eq '\l') {
5754 0           $char[$i] = '@{[Elatin10::lcfirst qq<';
5755 0           $left_e++;
5756             }
5757             elsif ($char[$i] eq '\U') {
5758 0           $char[$i] = '@{[Elatin10::uc qq<';
5759 0           $left_e++;
5760             }
5761             elsif ($char[$i] eq '\L') {
5762 0           $char[$i] = '@{[Elatin10::lc qq<';
5763 0           $left_e++;
5764             }
5765             elsif ($char[$i] eq '\F') {
5766 0           $char[$i] = '@{[Elatin10::fc qq<';
5767 0           $left_e++;
5768             }
5769             elsif ($char[$i] eq '\Q') {
5770 0           $char[$i] = '@{[CORE::quotemeta qq<';
5771 0           $left_e++;
5772             }
5773             elsif ($char[$i] eq '\E') {
5774 0 0         if ($right_e < $left_e) {
5775 0           $char[$i] = '>]}';
5776 0           $right_e++;
5777             }
5778             else {
5779 0           $char[$i] = '';
5780             }
5781             }
5782             elsif ($char[$i] eq '\Q') {
5783 0           while (1) {
5784 0 0         if (++$i > $#char) {
5785 0           last;
5786             }
5787 0 0         if ($char[$i] eq '\E') {
5788 0           last;
5789             }
5790             }
5791             }
5792             elsif ($char[$i] eq '\E') {
5793             }
5794              
5795             # $0 --> $0
5796             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5797 0 0         if ($ignorecase) {
5798 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5799             }
5800             }
5801             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5802 0 0         if ($ignorecase) {
5803 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5804             }
5805             }
5806              
5807             # $$ --> $$
5808             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5809             }
5810              
5811             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5812             # $1, $2, $3 --> $1, $2, $3 otherwise
5813             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5814 0           $char[$i] = e_capture($1);
5815 0 0         if ($ignorecase) {
5816 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5817             }
5818             }
5819             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5820 0           $char[$i] = e_capture($1);
5821 0 0         if ($ignorecase) {
5822 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5823             }
5824             }
5825              
5826             # $$foo[ ... ] --> $ $foo->[ ... ]
5827             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5828 0           $char[$i] = e_capture($1.'->'.$2);
5829 0 0         if ($ignorecase) {
5830 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5831             }
5832             }
5833              
5834             # $$foo{ ... } --> $ $foo->{ ... }
5835             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5836 0           $char[$i] = e_capture($1.'->'.$2);
5837 0 0         if ($ignorecase) {
5838 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5839             }
5840             }
5841              
5842             # $$foo
5843             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5844 0           $char[$i] = e_capture($1);
5845 0 0         if ($ignorecase) {
5846 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5847             }
5848             }
5849              
5850             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5851             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5852 0 0         if ($ignorecase) {
5853 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
5854             }
5855             else {
5856 0           $char[$i] = '@{[Elatin10::PREMATCH()]}';
5857             }
5858             }
5859              
5860             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5861             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5862 0 0         if ($ignorecase) {
5863 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
5864             }
5865             else {
5866 0           $char[$i] = '@{[Elatin10::MATCH()]}';
5867             }
5868             }
5869              
5870             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5871             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5872 0 0         if ($ignorecase) {
5873 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
5874             }
5875             else {
5876 0           $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5877             }
5878             }
5879              
5880             # ${ foo }
5881             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5882 0 0         if ($ignorecase) {
5883 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5884             }
5885             }
5886              
5887             # ${ ... }
5888             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5889 0           $char[$i] = e_capture($1);
5890 0 0         if ($ignorecase) {
5891 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5892             }
5893             }
5894              
5895             # $scalar or @array
5896             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5897 0           $char[$i] = e_string($char[$i]);
5898 0 0         if ($ignorecase) {
5899 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5900             }
5901             }
5902              
5903             # quote character before ? + * {
5904             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5905 0 0 0       if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5906             }
5907             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5908 0           my $char = $char[$i-1];
5909 0 0         if ($char[$i] eq '{') {
5910 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5911             }
5912             else {
5913 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5914             }
5915             }
5916             else {
5917 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5918             }
5919             }
5920             }
5921              
5922             # make regexp string
5923 0           $modifier =~ tr/i//d;
5924 0 0         if ($left_e > $right_e) {
5925 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5926 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5927             }
5928             else {
5929 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5930             }
5931             }
5932 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5933 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5934             }
5935             else {
5936 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5937             }
5938             }
5939              
5940             #
5941             # double quote stuff
5942             #
5943             sub qq_stuff {
5944 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5945              
5946             # scalar variable or array variable
5947 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5948 0           return $stuff;
5949             }
5950              
5951             # quote by delimiter
5952 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5953 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5954 0 0         next if $char eq $delimiter;
5955 0 0         next if $char eq $end_delimiter;
5956 0 0         if (not $octet{$char}) {
5957 0           return join '', 'qq', $char, $stuff, $char;
5958             }
5959             }
5960 0           return join '', 'qq', '<', $stuff, '>';
5961             }
5962              
5963             #
5964             # escape regexp (m'', qr'', and m''b, qr''b)
5965             #
5966             sub e_qr_q {
5967 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5968 0   0       $modifier ||= '';
5969              
5970 0           $modifier =~ tr/p//d;
5971 0 0         if ($modifier =~ /([adlu])/oxms) {
5972 0           my $line = 0;
5973 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5974 0 0         if ($filename ne __FILE__) {
5975 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5976 0           last;
5977             }
5978             }
5979 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5980             }
5981              
5982 0           $slash = 'div';
5983              
5984             # literal null string pattern
5985 0 0         if ($string eq '') {
    0          
5986 0           $modifier =~ tr/bB//d;
5987 0           $modifier =~ tr/i//d;
5988 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5989             }
5990              
5991             # with /b /B modifier
5992             elsif ($modifier =~ tr/bB//d) {
5993 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5994             }
5995              
5996             # without /b /B modifier
5997             else {
5998 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5999             }
6000             }
6001              
6002             #
6003             # escape regexp (m'', qr'')
6004             #
6005             sub e_qr_qt {
6006 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6007              
6008 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6009              
6010             # split regexp
6011 0           my @char = $string =~ /\G((?>
6012             [^\\\[\$\@\/] |
6013             [\x00-\xFF] |
6014             \[\^ |
6015             \[\: (?>[a-z]+) \:\] |
6016             \[\:\^ (?>[a-z]+) \:\] |
6017             [\$\@\/] |
6018             \\ (?:$q_char) |
6019             (?:$q_char)
6020             ))/oxmsg;
6021              
6022             # unescape character
6023 0           for (my $i=0; $i <= $#char; $i++) {
6024 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6025             }
6026              
6027             # open character class [...]
6028 0           elsif ($char[$i] eq '[') {
6029 0           my $left = $i;
6030 0 0         if ($char[$i+1] eq ']') {
6031 0           $i++;
6032             }
6033 0           while (1) {
6034 0 0         if (++$i > $#char) {
6035 0           die __FILE__, ": Unmatched [] in regexp\n";
6036             }
6037 0 0         if ($char[$i] eq ']') {
6038 0           my $right = $i;
6039              
6040             # [...]
6041 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6042              
6043 0           $i = $left;
6044 0           last;
6045             }
6046             }
6047             }
6048              
6049             # open character class [^...]
6050             elsif ($char[$i] eq '[^') {
6051 0           my $left = $i;
6052 0 0         if ($char[$i+1] eq ']') {
6053 0           $i++;
6054             }
6055 0           while (1) {
6056 0 0         if (++$i > $#char) {
6057 0           die __FILE__, ": Unmatched [] in regexp\n";
6058             }
6059 0 0         if ($char[$i] eq ']') {
6060 0           my $right = $i;
6061              
6062             # [^...]
6063 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6064              
6065 0           $i = $left;
6066 0           last;
6067             }
6068             }
6069             }
6070              
6071             # escape $ @ / and \
6072             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6073 0           $char[$i] = '\\' . $char[$i];
6074             }
6075              
6076             # rewrite character class or escape character
6077             elsif (my $char = character_class($char[$i],$modifier)) {
6078 0           $char[$i] = $char;
6079             }
6080              
6081             # /i modifier
6082             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6083 0 0         if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6084 0           $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6085             }
6086             else {
6087 0           $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6088             }
6089             }
6090              
6091             # quote character before ? + * {
6092             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6093 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6094             }
6095             else {
6096 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6097             }
6098             }
6099             }
6100              
6101 0           $delimiter = '/';
6102 0           $end_delimiter = '/';
6103              
6104 0           $modifier =~ tr/i//d;
6105 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6106             }
6107              
6108             #
6109             # escape regexp (m''b, qr''b)
6110             #
6111             sub e_qr_qb {
6112 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6113              
6114             # split regexp
6115 0           my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6116              
6117             # unescape character
6118 0           for (my $i=0; $i <= $#char; $i++) {
6119 0 0         if (0) {
    0          
6120             }
6121              
6122             # remain \\
6123 0           elsif ($char[$i] eq '\\\\') {
6124             }
6125              
6126             # escape $ @ / and \
6127             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6128 0           $char[$i] = '\\' . $char[$i];
6129             }
6130             }
6131              
6132 0           $delimiter = '/';
6133 0           $end_delimiter = '/';
6134 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6135             }
6136              
6137             #
6138             # escape regexp (s/here//)
6139             #
6140             sub e_s1 {
6141 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6142 0   0       $modifier ||= '';
6143              
6144 0           $modifier =~ tr/p//d;
6145 0 0         if ($modifier =~ /([adlu])/oxms) {
6146 0           my $line = 0;
6147 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6148 0 0         if ($filename ne __FILE__) {
6149 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6150 0           last;
6151             }
6152             }
6153 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6154             }
6155              
6156 0           $slash = 'div';
6157              
6158             # literal null string pattern
6159 0 0         if ($string eq '') {
    0          
6160 0           $modifier =~ tr/bB//d;
6161 0           $modifier =~ tr/i//d;
6162 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6163             }
6164              
6165             # /b /B modifier
6166             elsif ($modifier =~ tr/bB//d) {
6167              
6168             # choice again delimiter
6169 0 0         if ($delimiter =~ / [\@:] /oxms) {
6170 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6171 0           my %octet = map {$_ => 1} @char;
  0            
6172 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6173 0           $delimiter = '(';
6174 0           $end_delimiter = ')';
6175             }
6176             elsif (not $octet{'}'}) {
6177 0           $delimiter = '{';
6178 0           $end_delimiter = '}';
6179             }
6180             elsif (not $octet{']'}) {
6181 0           $delimiter = '[';
6182 0           $end_delimiter = ']';
6183             }
6184             elsif (not $octet{'>'}) {
6185 0           $delimiter = '<';
6186 0           $end_delimiter = '>';
6187             }
6188             else {
6189 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6190 0 0         if (not $octet{$char}) {
6191 0           $delimiter = $char;
6192 0           $end_delimiter = $char;
6193 0           last;
6194             }
6195             }
6196             }
6197             }
6198              
6199 0           my $prematch = '';
6200 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6201             }
6202              
6203 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6204 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6205              
6206             # split regexp
6207 0           my @char = $string =~ /\G((?>
6208             [^\\\$\@\[\(] |
6209             \\ (?>[1-9][0-9]*) |
6210             \\g (?>\s*) (?>[1-9][0-9]*) |
6211             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6212             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6213             \\x (?>[0-9A-Fa-f]{1,2}) |
6214             \\ (?>[0-7]{2,3}) |
6215             \\c [\x40-\x5F] |
6216             \\x\{ (?>[0-9A-Fa-f]+) \} |
6217             \\o\{ (?>[0-7]+) \} |
6218             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6219             \\ $q_char |
6220             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6221             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6222             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6223             [\$\@] $qq_variable |
6224             \$ (?>\s* [0-9]+) |
6225             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6226             \$ \$ (?![\w\{]) |
6227             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6228             \[\^ |
6229             \[\: (?>[a-z]+) :\] |
6230             \[\:\^ (?>[a-z]+) :\] |
6231             \(\? |
6232             $q_char
6233             ))/oxmsg;
6234              
6235             # choice again delimiter
6236 0 0         if ($delimiter =~ / [\@:] /oxms) {
6237 0           my %octet = map {$_ => 1} @char;
  0            
6238 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6239 0           $delimiter = '(';
6240 0           $end_delimiter = ')';
6241             }
6242             elsif (not $octet{'}'}) {
6243 0           $delimiter = '{';
6244 0           $end_delimiter = '}';
6245             }
6246             elsif (not $octet{']'}) {
6247 0           $delimiter = '[';
6248 0           $end_delimiter = ']';
6249             }
6250             elsif (not $octet{'>'}) {
6251 0           $delimiter = '<';
6252 0           $end_delimiter = '>';
6253             }
6254             else {
6255 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6256 0 0         if (not $octet{$char}) {
6257 0           $delimiter = $char;
6258 0           $end_delimiter = $char;
6259 0           last;
6260             }
6261             }
6262             }
6263             }
6264              
6265             # count '('
6266 0           my $parens = grep { $_ eq '(' } @char;
  0            
6267              
6268 0           my $left_e = 0;
6269 0           my $right_e = 0;
6270 0           for (my $i=0; $i <= $#char; $i++) {
6271              
6272             # "\L\u" --> "\u\L"
6273 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
6274 0           @char[$i,$i+1] = @char[$i+1,$i];
6275             }
6276              
6277             # "\U\l" --> "\l\U"
6278             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6279 0           @char[$i,$i+1] = @char[$i+1,$i];
6280             }
6281              
6282             # octal escape sequence
6283             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6284 0           $char[$i] = Elatin10::octchr($1);
6285             }
6286              
6287             # hexadecimal escape sequence
6288             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6289 0           $char[$i] = Elatin10::hexchr($1);
6290             }
6291              
6292             # \b{...} --> b\{...}
6293             # \B{...} --> B\{...}
6294             # \N{CHARNAME} --> N\{CHARNAME}
6295             # \p{PROPERTY} --> p\{PROPERTY}
6296             # \P{PROPERTY} --> P\{PROPERTY}
6297             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6298 0           $char[$i] = $1 . '\\' . $2;
6299             }
6300              
6301             # \p, \P, \X --> p, P, X
6302             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6303 0           $char[$i] = $1;
6304             }
6305              
6306 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6307             }
6308              
6309             # join separated multiple-octet
6310 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6311 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6312 0           $char[$i] .= join '', splice @char, $i+1, 3;
6313             }
6314             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)) {
6315 0           $char[$i] .= join '', splice @char, $i+1, 2;
6316             }
6317             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)) {
6318 0           $char[$i] .= join '', splice @char, $i+1, 1;
6319             }
6320             }
6321              
6322             # open character class [...]
6323             elsif ($char[$i] eq '[') {
6324 0           my $left = $i;
6325 0 0         if ($char[$i+1] eq ']') {
6326 0           $i++;
6327             }
6328 0           while (1) {
6329 0 0         if (++$i > $#char) {
6330 0           die __FILE__, ": Unmatched [] in regexp\n";
6331             }
6332 0 0         if ($char[$i] eq ']') {
6333 0           my $right = $i;
6334              
6335             # [...]
6336 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6337 0           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);
  0            
6338             }
6339             else {
6340 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6341             }
6342              
6343 0           $i = $left;
6344 0           last;
6345             }
6346             }
6347             }
6348              
6349             # open character class [^...]
6350             elsif ($char[$i] eq '[^') {
6351 0           my $left = $i;
6352 0 0         if ($char[$i+1] eq ']') {
6353 0           $i++;
6354             }
6355 0           while (1) {
6356 0 0         if (++$i > $#char) {
6357 0           die __FILE__, ": Unmatched [] in regexp\n";
6358             }
6359 0 0         if ($char[$i] eq ']') {
6360 0           my $right = $i;
6361              
6362             # [^...]
6363 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6364 0           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);
  0            
6365             }
6366             else {
6367 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6368             }
6369              
6370 0           $i = $left;
6371 0           last;
6372             }
6373             }
6374             }
6375              
6376             # rewrite character class or escape character
6377             elsif (my $char = character_class($char[$i],$modifier)) {
6378 0           $char[$i] = $char;
6379             }
6380              
6381             # /i modifier
6382             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6383 0 0         if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6384 0           $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6385             }
6386             else {
6387 0           $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6388             }
6389             }
6390              
6391             # \u \l \U \L \F \Q \E
6392             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6393 0 0         if ($right_e < $left_e) {
6394 0           $char[$i] = '\\' . $char[$i];
6395             }
6396             }
6397             elsif ($char[$i] eq '\u') {
6398 0           $char[$i] = '@{[Elatin10::ucfirst qq<';
6399 0           $left_e++;
6400             }
6401             elsif ($char[$i] eq '\l') {
6402 0           $char[$i] = '@{[Elatin10::lcfirst qq<';
6403 0           $left_e++;
6404             }
6405             elsif ($char[$i] eq '\U') {
6406 0           $char[$i] = '@{[Elatin10::uc qq<';
6407 0           $left_e++;
6408             }
6409             elsif ($char[$i] eq '\L') {
6410 0           $char[$i] = '@{[Elatin10::lc qq<';
6411 0           $left_e++;
6412             }
6413             elsif ($char[$i] eq '\F') {
6414 0           $char[$i] = '@{[Elatin10::fc qq<';
6415 0           $left_e++;
6416             }
6417             elsif ($char[$i] eq '\Q') {
6418 0           $char[$i] = '@{[CORE::quotemeta qq<';
6419 0           $left_e++;
6420             }
6421             elsif ($char[$i] eq '\E') {
6422 0 0         if ($right_e < $left_e) {
6423 0           $char[$i] = '>]}';
6424 0           $right_e++;
6425             }
6426             else {
6427 0           $char[$i] = '';
6428             }
6429             }
6430             elsif ($char[$i] eq '\Q') {
6431 0           while (1) {
6432 0 0         if (++$i > $#char) {
6433 0           last;
6434             }
6435 0 0         if ($char[$i] eq '\E') {
6436 0           last;
6437             }
6438             }
6439             }
6440             elsif ($char[$i] eq '\E') {
6441             }
6442              
6443             # \0 --> \0
6444             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6445             }
6446              
6447             # \g{N}, \g{-N}
6448              
6449             # P.108 Using Simple Patterns
6450             # in Chapter 7: In the World of Regular Expressions
6451             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6452              
6453             # P.221 Capturing
6454             # in Chapter 5: Pattern Matching
6455             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6456              
6457             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6458             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6459             }
6460              
6461             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6462             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6463             }
6464              
6465             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6466             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6467             }
6468              
6469             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6470             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6471             }
6472              
6473             # $0 --> $0
6474             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6475 0 0         if ($ignorecase) {
6476 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6477             }
6478             }
6479             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6480 0 0         if ($ignorecase) {
6481 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6482             }
6483             }
6484              
6485             # $$ --> $$
6486             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6487             }
6488              
6489             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6490             # $1, $2, $3 --> $1, $2, $3 otherwise
6491             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6492 0           $char[$i] = e_capture($1);
6493 0 0         if ($ignorecase) {
6494 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6495             }
6496             }
6497             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6498 0           $char[$i] = e_capture($1);
6499 0 0         if ($ignorecase) {
6500 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6501             }
6502             }
6503              
6504             # $$foo[ ... ] --> $ $foo->[ ... ]
6505             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6506 0           $char[$i] = e_capture($1.'->'.$2);
6507 0 0         if ($ignorecase) {
6508 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6509             }
6510             }
6511              
6512             # $$foo{ ... } --> $ $foo->{ ... }
6513             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6514 0           $char[$i] = e_capture($1.'->'.$2);
6515 0 0         if ($ignorecase) {
6516 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6517             }
6518             }
6519              
6520             # $$foo
6521             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6522 0           $char[$i] = e_capture($1);
6523 0 0         if ($ignorecase) {
6524 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6525             }
6526             }
6527              
6528             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
6529             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6530 0 0         if ($ignorecase) {
6531 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
6532             }
6533             else {
6534 0           $char[$i] = '@{[Elatin10::PREMATCH()]}';
6535             }
6536             }
6537              
6538             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
6539             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6540 0 0         if ($ignorecase) {
6541 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
6542             }
6543             else {
6544 0           $char[$i] = '@{[Elatin10::MATCH()]}';
6545             }
6546             }
6547              
6548             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
6549             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6550 0 0         if ($ignorecase) {
6551 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
6552             }
6553             else {
6554 0           $char[$i] = '@{[Elatin10::POSTMATCH()]}';
6555             }
6556             }
6557              
6558             # ${ foo }
6559             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6560 0 0         if ($ignorecase) {
6561 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6562             }
6563             }
6564              
6565             # ${ ... }
6566             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6567 0           $char[$i] = e_capture($1);
6568 0 0         if ($ignorecase) {
6569 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6570             }
6571             }
6572              
6573             # $scalar or @array
6574             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6575 0           $char[$i] = e_string($char[$i]);
6576 0 0         if ($ignorecase) {
6577 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6578             }
6579             }
6580              
6581             # quote character before ? + * {
6582             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6583 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6584             }
6585             else {
6586 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6587             }
6588             }
6589             }
6590              
6591             # make regexp string
6592 0           my $prematch = '';
6593 0           $modifier =~ tr/i//d;
6594 0 0         if ($left_e > $right_e) {
6595 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6596             }
6597 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6598             }
6599              
6600             #
6601             # escape regexp (s'here'' or s'here''b)
6602             #
6603             sub e_s1_q {
6604 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6605 0   0       $modifier ||= '';
6606              
6607 0           $modifier =~ tr/p//d;
6608 0 0         if ($modifier =~ /([adlu])/oxms) {
6609 0           my $line = 0;
6610 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6611 0 0         if ($filename ne __FILE__) {
6612 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6613 0           last;
6614             }
6615             }
6616 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6617             }
6618              
6619 0           $slash = 'div';
6620              
6621             # literal null string pattern
6622 0 0         if ($string eq '') {
    0          
6623 0           $modifier =~ tr/bB//d;
6624 0           $modifier =~ tr/i//d;
6625 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6626             }
6627              
6628             # with /b /B modifier
6629             elsif ($modifier =~ tr/bB//d) {
6630 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6631             }
6632              
6633             # without /b /B modifier
6634             else {
6635 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6636             }
6637             }
6638              
6639             #
6640             # escape regexp (s'here'')
6641             #
6642             sub e_s1_qt {
6643 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6644              
6645 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6646              
6647             # split regexp
6648 0           my @char = $string =~ /\G((?>
6649             [^\\\[\$\@\/] |
6650             [\x00-\xFF] |
6651             \[\^ |
6652             \[\: (?>[a-z]+) \:\] |
6653             \[\:\^ (?>[a-z]+) \:\] |
6654             [\$\@\/] |
6655             \\ (?:$q_char) |
6656             (?:$q_char)
6657             ))/oxmsg;
6658              
6659             # unescape character
6660 0           for (my $i=0; $i <= $#char; $i++) {
6661 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6662             }
6663              
6664             # open character class [...]
6665 0           elsif ($char[$i] eq '[') {
6666 0           my $left = $i;
6667 0 0         if ($char[$i+1] eq ']') {
6668 0           $i++;
6669             }
6670 0           while (1) {
6671 0 0         if (++$i > $#char) {
6672 0           die __FILE__, ": Unmatched [] in regexp\n";
6673             }
6674 0 0         if ($char[$i] eq ']') {
6675 0           my $right = $i;
6676              
6677             # [...]
6678 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6679              
6680 0           $i = $left;
6681 0           last;
6682             }
6683             }
6684             }
6685              
6686             # open character class [^...]
6687             elsif ($char[$i] eq '[^') {
6688 0           my $left = $i;
6689 0 0         if ($char[$i+1] eq ']') {
6690 0           $i++;
6691             }
6692 0           while (1) {
6693 0 0         if (++$i > $#char) {
6694 0           die __FILE__, ": Unmatched [] in regexp\n";
6695             }
6696 0 0         if ($char[$i] eq ']') {
6697 0           my $right = $i;
6698              
6699             # [^...]
6700 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6701              
6702 0           $i = $left;
6703 0           last;
6704             }
6705             }
6706             }
6707              
6708             # escape $ @ / and \
6709             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6710 0           $char[$i] = '\\' . $char[$i];
6711             }
6712              
6713             # rewrite character class or escape character
6714             elsif (my $char = character_class($char[$i],$modifier)) {
6715 0           $char[$i] = $char;
6716             }
6717              
6718             # /i modifier
6719             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6720 0 0         if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6721 0           $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6722             }
6723             else {
6724 0           $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6725             }
6726             }
6727              
6728             # quote character before ? + * {
6729             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6730 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6731             }
6732             else {
6733 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6734             }
6735             }
6736             }
6737              
6738 0           $modifier =~ tr/i//d;
6739 0           $delimiter = '/';
6740 0           $end_delimiter = '/';
6741 0           my $prematch = '';
6742 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6743             }
6744              
6745             #
6746             # escape regexp (s'here''b)
6747             #
6748             sub e_s1_qb {
6749 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6750              
6751             # split regexp
6752 0           my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6753              
6754             # unescape character
6755 0           for (my $i=0; $i <= $#char; $i++) {
6756 0 0         if (0) {
    0          
6757             }
6758              
6759             # remain \\
6760 0           elsif ($char[$i] eq '\\\\') {
6761             }
6762              
6763             # escape $ @ / and \
6764             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6765 0           $char[$i] = '\\' . $char[$i];
6766             }
6767             }
6768              
6769 0           $delimiter = '/';
6770 0           $end_delimiter = '/';
6771 0           my $prematch = '';
6772 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6773             }
6774              
6775             #
6776             # escape regexp (s''here')
6777             #
6778             sub e_s2_q {
6779 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6780              
6781 0           $slash = 'div';
6782              
6783 0           my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6784 0           for (my $i=0; $i <= $#char; $i++) {
6785 0 0         if (0) {
    0          
6786             }
6787              
6788             # not escape \\
6789 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6790             }
6791              
6792             # escape $ @ / and \
6793             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6794 0           $char[$i] = '\\' . $char[$i];
6795             }
6796             }
6797              
6798 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6799             }
6800              
6801             #
6802             # escape regexp (s/here/and here/modifier)
6803             #
6804             sub e_sub {
6805 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6806 0   0       $modifier ||= '';
6807              
6808 0           $modifier =~ tr/p//d;
6809 0 0         if ($modifier =~ /([adlu])/oxms) {
6810 0           my $line = 0;
6811 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6812 0 0         if ($filename ne __FILE__) {
6813 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6814 0           last;
6815             }
6816             }
6817 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6818             }
6819              
6820 0 0         if ($variable eq '') {
6821 0           $variable = '$_';
6822 0           $bind_operator = ' =~ ';
6823             }
6824              
6825 0           $slash = 'div';
6826              
6827             # P.128 Start of match (or end of previous match): \G
6828             # P.130 Advanced Use of \G with Perl
6829             # in Chapter 3: Overview of Regular Expression Features and Flavors
6830             # P.312 Iterative Matching: Scalar Context, with /g
6831             # in Chapter 7: Perl
6832             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6833              
6834             # P.181 Where You Left Off: The \G Assertion
6835             # in Chapter 5: Pattern Matching
6836             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6837              
6838             # P.220 Where You Left Off: The \G Assertion
6839             # in Chapter 5: Pattern Matching
6840             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6841              
6842 0           my $e_modifier = $modifier =~ tr/e//d;
6843 0           my $r_modifier = $modifier =~ tr/r//d;
6844              
6845 0           my $my = '';
6846 0 0         if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6847 0           $my = $variable;
6848 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6849 0           $variable =~ s/ = .+ \z//oxms;
6850             }
6851              
6852 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6853 0           $variable_basename =~ s/ \s+ \z//oxms;
6854              
6855             # quote replacement string
6856 0           my $e_replacement = '';
6857 0 0         if ($e_modifier >= 1) {
6858 0           $e_replacement = e_qq('', '', '', $replacement);
6859 0           $e_modifier--;
6860             }
6861             else {
6862 0 0         if ($delimiter2 eq "'") {
6863 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6864             }
6865             else {
6866 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6867             }
6868             }
6869              
6870 0           my $sub = '';
6871              
6872             # with /r
6873 0 0         if ($r_modifier) {
6874 0 0         if (0) {
6875             }
6876              
6877             # s///gr without multibyte anchoring
6878 0           elsif ($modifier =~ /g/oxms) {
6879 0 0         $sub = sprintf(
6880             # 1 2 3 4 5
6881             q,
6882              
6883             $variable, # 1
6884             ($delimiter1 eq "'") ? # 2
6885             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6886             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6887             $s_matched, # 3
6888             $e_replacement, # 4
6889             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 5
6890             );
6891             }
6892              
6893             # s///r
6894             else {
6895              
6896 0           my $prematch = q{$`};
6897              
6898 0 0         $sub = sprintf(
6899             # 1 2 3 4 5 6 7
6900             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin10::re_r=%s; %s"%s$Latin10::re_r$'" } : %s>,
6901              
6902             $variable, # 1
6903             ($delimiter1 eq "'") ? # 2
6904             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6905             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6906             $s_matched, # 3
6907             $e_replacement, # 4
6908             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 5
6909             $prematch, # 6
6910             $variable, # 7
6911             );
6912             }
6913              
6914             # $var !~ s///r doesn't make sense
6915 0 0         if ($bind_operator =~ / !~ /oxms) {
6916 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6917             }
6918             }
6919              
6920             # without /r
6921             else {
6922 0 0         if (0) {
6923             }
6924              
6925             # s///g without multibyte anchoring
6926 0           elsif ($modifier =~ /g/oxms) {
6927 0 0         $sub = sprintf(
    0          
6928             # 1 2 3 4 5 6 7 8
6929             q,
6930              
6931             $variable, # 1
6932             ($delimiter1 eq "'") ? # 2
6933             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6934             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6935             $s_matched, # 3
6936             $e_replacement, # 4
6937             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 5
6938             $variable, # 6
6939             $variable, # 7
6940             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6941             );
6942             }
6943              
6944             # s///
6945             else {
6946              
6947 0           my $prematch = q{$`};
6948              
6949 0 0         $sub = sprintf(
    0          
6950              
6951             ($bind_operator =~ / =~ /oxms) ?
6952              
6953             # 1 2 3 4 5 6 7 8
6954             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin10::re_r=%s; %s%s="%s$Latin10::re_r$'"; 1 } : undef> :
6955              
6956             # 1 2 3 4 5 6 7 8
6957             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin10::re_r=%s; %s%s="%s$Latin10::re_r$'"; undef }>,
6958              
6959             $variable, # 1
6960             $bind_operator, # 2
6961             ($delimiter1 eq "'") ? # 3
6962             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6963             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6964             $s_matched, # 4
6965             $e_replacement, # 5
6966             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 6
6967             $variable, # 7
6968             $prematch, # 8
6969             );
6970             }
6971             }
6972              
6973             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6974 0 0         if ($my ne '') {
6975 0           $sub = "($my, $sub)[1]";
6976             }
6977              
6978             # clear s/// variable
6979 0           $sub_variable = '';
6980 0           $bind_operator = '';
6981              
6982 0           return $sub;
6983             }
6984              
6985             #
6986             # escape regexp of split qr//
6987             #
6988             sub e_split {
6989 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6990 0   0       $modifier ||= '';
6991              
6992 0           $modifier =~ tr/p//d;
6993 0 0         if ($modifier =~ /([adlu])/oxms) {
6994 0           my $line = 0;
6995 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6996 0 0         if ($filename ne __FILE__) {
6997 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6998 0           last;
6999             }
7000             }
7001 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7002             }
7003              
7004 0           $slash = 'div';
7005              
7006             # /b /B modifier
7007 0 0         if ($modifier =~ tr/bB//d) {
7008 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7009             }
7010              
7011 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7012 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
7013              
7014             # split regexp
7015 0           my @char = $string =~ /\G((?>
7016             [^\\\$\@\[\(] |
7017             \\x (?>[0-9A-Fa-f]{1,2}) |
7018             \\ (?>[0-7]{2,3}) |
7019             \\c [\x40-\x5F] |
7020             \\x\{ (?>[0-9A-Fa-f]+) \} |
7021             \\o\{ (?>[0-7]+) \} |
7022             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7023             \\ $q_char |
7024             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7025             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7026             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7027             [\$\@] $qq_variable |
7028             \$ (?>\s* [0-9]+) |
7029             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7030             \$ \$ (?![\w\{]) |
7031             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7032             \[\^ |
7033             \[\: (?>[a-z]+) :\] |
7034             \[\:\^ (?>[a-z]+) :\] |
7035             \(\? |
7036             $q_char
7037             ))/oxmsg;
7038              
7039 0           my $left_e = 0;
7040 0           my $right_e = 0;
7041 0           for (my $i=0; $i <= $#char; $i++) {
7042              
7043             # "\L\u" --> "\u\L"
7044 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
7045 0           @char[$i,$i+1] = @char[$i+1,$i];
7046             }
7047              
7048             # "\U\l" --> "\l\U"
7049             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7050 0           @char[$i,$i+1] = @char[$i+1,$i];
7051             }
7052              
7053             # octal escape sequence
7054             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7055 0           $char[$i] = Elatin10::octchr($1);
7056             }
7057              
7058             # hexadecimal escape sequence
7059             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7060 0           $char[$i] = Elatin10::hexchr($1);
7061             }
7062              
7063             # \b{...} --> b\{...}
7064             # \B{...} --> B\{...}
7065             # \N{CHARNAME} --> N\{CHARNAME}
7066             # \p{PROPERTY} --> p\{PROPERTY}
7067             # \P{PROPERTY} --> P\{PROPERTY}
7068             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7069 0           $char[$i] = $1 . '\\' . $2;
7070             }
7071              
7072             # \p, \P, \X --> p, P, X
7073             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7074 0           $char[$i] = $1;
7075             }
7076              
7077 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7078             }
7079              
7080             # join separated multiple-octet
7081 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7082 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
7083 0           $char[$i] .= join '', splice @char, $i+1, 3;
7084             }
7085             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)) {
7086 0           $char[$i] .= join '', splice @char, $i+1, 2;
7087             }
7088             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)) {
7089 0           $char[$i] .= join '', splice @char, $i+1, 1;
7090             }
7091             }
7092              
7093             # open character class [...]
7094             elsif ($char[$i] eq '[') {
7095 0           my $left = $i;
7096 0 0         if ($char[$i+1] eq ']') {
7097 0           $i++;
7098             }
7099 0           while (1) {
7100 0 0         if (++$i > $#char) {
7101 0           die __FILE__, ": Unmatched [] in regexp\n";
7102             }
7103 0 0         if ($char[$i] eq ']') {
7104 0           my $right = $i;
7105              
7106             # [...]
7107 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7108 0           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);
  0            
7109             }
7110             else {
7111 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7112             }
7113              
7114 0           $i = $left;
7115 0           last;
7116             }
7117             }
7118             }
7119              
7120             # open character class [^...]
7121             elsif ($char[$i] eq '[^') {
7122 0           my $left = $i;
7123 0 0         if ($char[$i+1] eq ']') {
7124 0           $i++;
7125             }
7126 0           while (1) {
7127 0 0         if (++$i > $#char) {
7128 0           die __FILE__, ": Unmatched [] in regexp\n";
7129             }
7130 0 0         if ($char[$i] eq ']') {
7131 0           my $right = $i;
7132              
7133             # [^...]
7134 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7135 0           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);
  0            
7136             }
7137             else {
7138 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7139             }
7140              
7141 0           $i = $left;
7142 0           last;
7143             }
7144             }
7145             }
7146              
7147             # rewrite character class or escape character
7148             elsif (my $char = character_class($char[$i],$modifier)) {
7149 0           $char[$i] = $char;
7150             }
7151              
7152             # P.794 29.2.161. split
7153             # in Chapter 29: Functions
7154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7155              
7156             # P.951 split
7157             # in Chapter 27: Functions
7158             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7159              
7160             # said "The //m modifier is assumed when you split on the pattern /^/",
7161             # but perl5.008 is not so. Therefore, this software adds //m.
7162             # (and so on)
7163              
7164             # split(m/^/) --> split(m/^/m)
7165             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7166 0           $modifier .= 'm';
7167             }
7168              
7169             # /i modifier
7170             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7171 0 0         if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7172 0           $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7173             }
7174             else {
7175 0           $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7176             }
7177             }
7178              
7179             # \u \l \U \L \F \Q \E
7180             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7181 0 0         if ($right_e < $left_e) {
7182 0           $char[$i] = '\\' . $char[$i];
7183             }
7184             }
7185             elsif ($char[$i] eq '\u') {
7186 0           $char[$i] = '@{[Elatin10::ucfirst qq<';
7187 0           $left_e++;
7188             }
7189             elsif ($char[$i] eq '\l') {
7190 0           $char[$i] = '@{[Elatin10::lcfirst qq<';
7191 0           $left_e++;
7192             }
7193             elsif ($char[$i] eq '\U') {
7194 0           $char[$i] = '@{[Elatin10::uc qq<';
7195 0           $left_e++;
7196             }
7197             elsif ($char[$i] eq '\L') {
7198 0           $char[$i] = '@{[Elatin10::lc qq<';
7199 0           $left_e++;
7200             }
7201             elsif ($char[$i] eq '\F') {
7202 0           $char[$i] = '@{[Elatin10::fc qq<';
7203 0           $left_e++;
7204             }
7205             elsif ($char[$i] eq '\Q') {
7206 0           $char[$i] = '@{[CORE::quotemeta qq<';
7207 0           $left_e++;
7208             }
7209             elsif ($char[$i] eq '\E') {
7210 0 0         if ($right_e < $left_e) {
7211 0           $char[$i] = '>]}';
7212 0           $right_e++;
7213             }
7214             else {
7215 0           $char[$i] = '';
7216             }
7217             }
7218             elsif ($char[$i] eq '\Q') {
7219 0           while (1) {
7220 0 0         if (++$i > $#char) {
7221 0           last;
7222             }
7223 0 0         if ($char[$i] eq '\E') {
7224 0           last;
7225             }
7226             }
7227             }
7228             elsif ($char[$i] eq '\E') {
7229             }
7230              
7231             # $0 --> $0
7232             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7233 0 0         if ($ignorecase) {
7234 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7235             }
7236             }
7237             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7238 0 0         if ($ignorecase) {
7239 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7240             }
7241             }
7242              
7243             # $$ --> $$
7244             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7245             }
7246              
7247             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7248             # $1, $2, $3 --> $1, $2, $3 otherwise
7249             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7250 0           $char[$i] = e_capture($1);
7251 0 0         if ($ignorecase) {
7252 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7253             }
7254             }
7255             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7256 0           $char[$i] = e_capture($1);
7257 0 0         if ($ignorecase) {
7258 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7259             }
7260             }
7261              
7262             # $$foo[ ... ] --> $ $foo->[ ... ]
7263             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7264 0           $char[$i] = e_capture($1.'->'.$2);
7265 0 0         if ($ignorecase) {
7266 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7267             }
7268             }
7269              
7270             # $$foo{ ... } --> $ $foo->{ ... }
7271             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7272 0           $char[$i] = e_capture($1.'->'.$2);
7273 0 0         if ($ignorecase) {
7274 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7275             }
7276             }
7277              
7278             # $$foo
7279             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7280 0           $char[$i] = e_capture($1);
7281 0 0         if ($ignorecase) {
7282 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7283             }
7284             }
7285              
7286             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
7287             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7288 0 0         if ($ignorecase) {
7289 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
7290             }
7291             else {
7292 0           $char[$i] = '@{[Elatin10::PREMATCH()]}';
7293             }
7294             }
7295              
7296             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
7297             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7298 0 0         if ($ignorecase) {
7299 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
7300             }
7301             else {
7302 0           $char[$i] = '@{[Elatin10::MATCH()]}';
7303             }
7304             }
7305              
7306             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
7307             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7308 0 0         if ($ignorecase) {
7309 0           $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
7310             }
7311             else {
7312 0           $char[$i] = '@{[Elatin10::POSTMATCH()]}';
7313             }
7314             }
7315              
7316             # ${ foo }
7317             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7318 0 0         if ($ignorecase) {
7319 0           $char[$i] = '@{[Elatin10::ignorecase(' . $1 . ')]}';
7320             }
7321             }
7322              
7323             # ${ ... }
7324             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7325 0           $char[$i] = e_capture($1);
7326 0 0         if ($ignorecase) {
7327 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7328             }
7329             }
7330              
7331             # $scalar or @array
7332             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7333 0           $char[$i] = e_string($char[$i]);
7334 0 0         if ($ignorecase) {
7335 0           $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7336             }
7337             }
7338              
7339             # quote character before ? + * {
7340             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7341 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7342             }
7343             else {
7344 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7345             }
7346             }
7347             }
7348              
7349             # make regexp string
7350 0           $modifier =~ tr/i//d;
7351 0 0         if ($left_e > $right_e) {
7352 0           return join '', 'Elatin10::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7353             }
7354 0           return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7355             }
7356              
7357             #
7358             # escape regexp of split qr''
7359             #
7360             sub e_split_q {
7361 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7362 0   0       $modifier ||= '';
7363              
7364 0           $modifier =~ tr/p//d;
7365 0 0         if ($modifier =~ /([adlu])/oxms) {
7366 0           my $line = 0;
7367 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7368 0 0         if ($filename ne __FILE__) {
7369 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7370 0           last;
7371             }
7372             }
7373 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7374             }
7375              
7376 0           $slash = 'div';
7377              
7378             # /b /B modifier
7379 0 0         if ($modifier =~ tr/bB//d) {
7380 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7381             }
7382              
7383 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7384              
7385             # split regexp
7386 0           my @char = $string =~ /\G((?>
7387             [^\\\[] |
7388             [\x00-\xFF] |
7389             \[\^ |
7390             \[\: (?>[a-z]+) \:\] |
7391             \[\:\^ (?>[a-z]+) \:\] |
7392             \\ (?:$q_char) |
7393             (?:$q_char)
7394             ))/oxmsg;
7395              
7396             # unescape character
7397 0           for (my $i=0; $i <= $#char; $i++) {
7398 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7399             }
7400              
7401             # open character class [...]
7402 0           elsif ($char[$i] eq '[') {
7403 0           my $left = $i;
7404 0 0         if ($char[$i+1] eq ']') {
7405 0           $i++;
7406             }
7407 0           while (1) {
7408 0 0         if (++$i > $#char) {
7409 0           die __FILE__, ": Unmatched [] in regexp\n";
7410             }
7411 0 0         if ($char[$i] eq ']') {
7412 0           my $right = $i;
7413              
7414             # [...]
7415 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7416              
7417 0           $i = $left;
7418 0           last;
7419             }
7420             }
7421             }
7422              
7423             # open character class [^...]
7424             elsif ($char[$i] eq '[^') {
7425 0           my $left = $i;
7426 0 0         if ($char[$i+1] eq ']') {
7427 0           $i++;
7428             }
7429 0           while (1) {
7430 0 0         if (++$i > $#char) {
7431 0           die __FILE__, ": Unmatched [] in regexp\n";
7432             }
7433 0 0         if ($char[$i] eq ']') {
7434 0           my $right = $i;
7435              
7436             # [^...]
7437 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7438              
7439 0           $i = $left;
7440 0           last;
7441             }
7442             }
7443             }
7444              
7445             # rewrite character class or escape character
7446             elsif (my $char = character_class($char[$i],$modifier)) {
7447 0           $char[$i] = $char;
7448             }
7449              
7450             # split(m/^/) --> split(m/^/m)
7451             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7452 0           $modifier .= 'm';
7453             }
7454              
7455             # /i modifier
7456             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7457 0 0         if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7458 0           $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7459             }
7460             else {
7461 0           $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7462             }
7463             }
7464              
7465             # quote character before ? + * {
7466             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7467 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7468             }
7469             else {
7470 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7471             }
7472             }
7473             }
7474              
7475 0           $modifier =~ tr/i//d;
7476 0           return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7477             }
7478              
7479             #
7480             # instead of Carp::carp
7481             #
7482             sub carp {
7483 0     0 0   my($package,$filename,$line) = caller(1);
7484 0           print STDERR "@_ at $filename line $line.\n";
7485             }
7486              
7487             #
7488             # instead of Carp::croak
7489             #
7490             sub croak {
7491 0     0 0   my($package,$filename,$line) = caller(1);
7492 0           print STDERR "@_ at $filename line $line.\n";
7493 0           die "\n";
7494             }
7495              
7496             #
7497             # instead of Carp::cluck
7498             #
7499             sub cluck {
7500 0     0 0   my $i = 0;
7501 0           my @cluck = ();
7502 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7503 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7504 0           $i++;
7505             }
7506 0           print STDERR CORE::reverse @cluck;
7507 0           print STDERR "\n";
7508 0           carp @_;
7509             }
7510              
7511             #
7512             # instead of Carp::confess
7513             #
7514             sub confess {
7515 0     0 0   my $i = 0;
7516 0           my @confess = ();
7517 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7518 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7519 0           $i++;
7520             }
7521 0           print STDERR CORE::reverse @confess;
7522 0           print STDERR "\n";
7523 0           croak @_;
7524             }
7525              
7526             1;
7527              
7528             __END__