File Coverage

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


line stmt bran cond sub pod time code
1             package Elatin2;
2 204     204   1233 use strict;
  204         317  
  204         25172  
3             ######################################################################
4             #
5             # Elatin2 - Run-time routines for Latin2.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin2/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   4174 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         616  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 204     204   1378 use vars qw($VERSION);
  204         370  
  204         31067  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1808 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         370 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         31666 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44              
45             # instead of utf8.pm
46 204     204   18731 CORE::eval q{
  204     204   2567  
  204     64   491  
  204         26681  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 204 50       103947 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0     0 0 0 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     0 0 0 my($name) = @_;
73              
74 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
75 0         0 return $name;
76             }
77             elsif (Elatin2::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Elatin2::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 0         0 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 0   0 0 0 if (defined $_[1]) {
112 204     204   1707 no strict qw(refs);
  204         594  
  204         18584  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1252 no strict qw(refs);
  204     0   361  
  204         40489  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x00-\xFF]};
148 204     204   1409 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         454  
  204         16656  
149 204     204   1362 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         452  
  204         466850  
150              
151             #
152             # Latin-2 character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # Latin-2 case conversion
158             #
159             my %lc = ();
160             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
161             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
162             my %uc = ();
163             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
164             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
165             my %fc = ();
166             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
167             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Elatin2 \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177              
178             %lc = (%lc,
179             "\xA1" => "\xB1", # LATIN LETTER A WITH OGONEK
180             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
181             "\xA5" => "\xB5", # LATIN LETTER L WITH CARON
182             "\xA6" => "\xB6", # LATIN LETTER S WITH ACUTE
183             "\xA9" => "\xB9", # LATIN LETTER S WITH CARON
184             "\xAA" => "\xBA", # LATIN LETTER S WITH CEDILLA
185             "\xAB" => "\xBB", # LATIN LETTER T WITH CARON
186             "\xAC" => "\xBC", # LATIN LETTER Z WITH ACUTE
187             "\xAE" => "\xBE", # LATIN LETTER Z WITH CARON
188             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
189             "\xC0" => "\xE0", # LATIN LETTER R WITH ACUTE
190             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
191             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
192             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
193             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
194             "\xC5" => "\xE5", # LATIN LETTER L WITH ACUTE
195             "\xC6" => "\xE6", # LATIN LETTER C WITH ACUTE
196             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
197             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
198             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
199             "\xCA" => "\xEA", # LATIN LETTER E WITH OGONEK
200             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
201             "\xCC" => "\xEC", # LATIN LETTER E WITH CARON
202             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
203             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
204             "\xCF" => "\xEF", # LATIN LETTER D WITH CARON
205             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
206             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
207             "\xD2" => "\xF2", # LATIN LETTER N WITH CARON
208             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
209             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
210             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
211             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
212             "\xD8" => "\xF8", # LATIN LETTER R WITH CARON
213             "\xD9" => "\xF9", # LATIN LETTER U WITH RING ABOVE
214             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
215             "\xDB" => "\xFB", # LATIN LETTER U WITH DOUBLE ACUTE
216             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
217             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
218             "\xDE" => "\xFE", # LATIN LETTER T WITH CEDILLA
219             );
220              
221             %uc = (%uc,
222             "\xB1" => "\xA1", # LATIN LETTER A WITH OGONEK
223             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
224             "\xB5" => "\xA5", # LATIN LETTER L WITH CARON
225             "\xB6" => "\xA6", # LATIN LETTER S WITH ACUTE
226             "\xB9" => "\xA9", # LATIN LETTER S WITH CARON
227             "\xBA" => "\xAA", # LATIN LETTER S WITH CEDILLA
228             "\xBB" => "\xAB", # LATIN LETTER T WITH CARON
229             "\xBC" => "\xAC", # LATIN LETTER Z WITH ACUTE
230             "\xBE" => "\xAE", # LATIN LETTER Z WITH CARON
231             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
232             "\xE0" => "\xC0", # LATIN LETTER R WITH ACUTE
233             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
234             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
235             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
236             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
237             "\xE5" => "\xC5", # LATIN LETTER L WITH ACUTE
238             "\xE6" => "\xC6", # LATIN LETTER C WITH ACUTE
239             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
240             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
241             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
242             "\xEA" => "\xCA", # LATIN LETTER E WITH OGONEK
243             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
244             "\xEC" => "\xCC", # LATIN LETTER E WITH CARON
245             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
246             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
247             "\xEF" => "\xCF", # LATIN LETTER D WITH CARON
248             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
249             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
250             "\xF2" => "\xD2", # LATIN LETTER N WITH CARON
251             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
252             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
253             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
254             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
255             "\xF8" => "\xD8", # LATIN LETTER R WITH CARON
256             "\xF9" => "\xD9", # LATIN LETTER U WITH RING ABOVE
257             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
258             "\xFB" => "\xDB", # LATIN LETTER U WITH DOUBLE ACUTE
259             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
260             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
261             "\xFE" => "\xDE", # LATIN LETTER T WITH CEDILLA
262             );
263              
264             %fc = (%fc,
265             "\xA1" => "\xB1", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
266             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
267             "\xA5" => "\xB5", # LATIN CAPITAL LETTER L WITH CARON --> LATIN SMALL LETTER L WITH CARON
268             "\xA6" => "\xB6", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
269             "\xA9" => "\xB9", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
270             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH CEDILLA --> LATIN SMALL LETTER S WITH CEDILLA
271             "\xAB" => "\xBB", # LATIN CAPITAL LETTER T WITH CARON --> LATIN SMALL LETTER T WITH CARON
272             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
273             "\xAE" => "\xBE", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
274             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
275             "\xC0" => "\xE0", # LATIN CAPITAL LETTER R WITH ACUTE --> LATIN SMALL LETTER R WITH ACUTE
276             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
277             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
278             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
279             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
280             "\xC5" => "\xE5", # LATIN CAPITAL LETTER L WITH ACUTE --> LATIN SMALL LETTER L WITH ACUTE
281             "\xC6" => "\xE6", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
282             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
283             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
284             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
285             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
286             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
287             "\xCC" => "\xEC", # LATIN CAPITAL LETTER E WITH CARON --> LATIN SMALL LETTER E WITH CARON
288             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
289             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
290             "\xCF" => "\xEF", # LATIN CAPITAL LETTER D WITH CARON --> LATIN SMALL LETTER D WITH CARON
291             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
292             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
293             "\xD2" => "\xF2", # LATIN CAPITAL LETTER N WITH CARON --> LATIN SMALL LETTER N WITH CARON
294             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
295             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
296             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
297             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
298             "\xD8" => "\xF8", # LATIN CAPITAL LETTER R WITH CARON --> LATIN SMALL LETTER R WITH CARON
299             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH RING ABOVE --> LATIN SMALL LETTER U WITH RING ABOVE
300             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
301             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
302             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
303             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
304             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH CEDILLA --> LATIN SMALL LETTER T WITH CEDILLA
305             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
306             );
307             }
308              
309             else {
310             croak "Don't know my package name '@{[__PACKAGE__]}'";
311             }
312              
313             #
314             # @ARGV wildcard globbing
315             #
316             sub import {
317              
318 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
319 0         0 my @argv = ();
320 0         0 for (@ARGV) {
321              
322             # has space
323 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
324 0 0       0 if (my @glob = Elatin2::glob(qq{"$_"})) {
325 0         0 push @argv, @glob;
326             }
327             else {
328 0         0 push @argv, $_;
329             }
330             }
331              
332             # has wildcard metachar
333             elsif (/\A (?:$q_char)*? [*?] /oxms) {
334 0 0       0 if (my @glob = Elatin2::glob($_)) {
335 0         0 push @argv, @glob;
336             }
337             else {
338 0         0 push @argv, $_;
339             }
340             }
341              
342             # no wildcard globbing
343             else {
344 0         0 push @argv, $_;
345             }
346             }
347 0         0 @ARGV = @argv;
348             }
349              
350 0         0 *Char::ord = \&Latin2::ord;
351 0         0 *Char::ord_ = \&Latin2::ord_;
352 0         0 *Char::reverse = \&Latin2::reverse;
353 0         0 *Char::getc = \&Latin2::getc;
354 0         0 *Char::length = \&Latin2::length;
355 0         0 *Char::substr = \&Latin2::substr;
356 0         0 *Char::index = \&Latin2::index;
357 0         0 *Char::rindex = \&Latin2::rindex;
358 0         0 *Char::eval = \&Latin2::eval;
359 0         0 *Char::escape = \&Latin2::escape;
360 0         0 *Char::escape_token = \&Latin2::escape_token;
361 0         0 *Char::escape_script = \&Latin2::escape_script;
362             }
363              
364             # P.230 Care with Prototypes
365             # in Chapter 6: Subroutines
366             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
367             #
368             # If you aren't careful, you can get yourself into trouble with prototypes.
369             # But if you are careful, you can do a lot of neat things with them. This is
370             # all very powerful, of course, and should only be used in moderation to make
371             # the world a better place.
372              
373             # P.332 Care with Prototypes
374             # in Chapter 7: Subroutines
375             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
376             #
377             # If you aren't careful, you can get yourself into trouble with prototypes.
378             # But if you are careful, you can do a lot of neat things with them. This is
379             # all very powerful, of course, and should only be used in moderation to make
380             # the world a better place.
381              
382             #
383             # Prototypes of subroutines
384             #
385       0     sub unimport {}
386             sub Elatin2::split(;$$$);
387             sub Elatin2::tr($$$$;$);
388             sub Elatin2::chop(@);
389             sub Elatin2::index($$;$);
390             sub Elatin2::rindex($$;$);
391             sub Elatin2::lcfirst(@);
392             sub Elatin2::lcfirst_();
393             sub Elatin2::lc(@);
394             sub Elatin2::lc_();
395             sub Elatin2::ucfirst(@);
396             sub Elatin2::ucfirst_();
397             sub Elatin2::uc(@);
398             sub Elatin2::uc_();
399             sub Elatin2::fc(@);
400             sub Elatin2::fc_();
401             sub Elatin2::ignorecase;
402             sub Elatin2::classic_character_class;
403             sub Elatin2::capture;
404             sub Elatin2::chr(;$);
405             sub Elatin2::chr_();
406             sub Elatin2::glob($);
407             sub Elatin2::glob_();
408              
409             sub Latin2::ord(;$);
410             sub Latin2::ord_();
411             sub Latin2::reverse(@);
412             sub Latin2::getc(;*@);
413             sub Latin2::length(;$);
414             sub Latin2::substr($$;$$);
415             sub Latin2::index($$;$);
416             sub Latin2::rindex($$;$);
417             sub Latin2::escape(;$);
418              
419             #
420             # Regexp work
421             #
422 204         19413 use vars qw(
423             $re_a
424             $re_t
425             $re_n
426             $re_r
427 204     204   1717 );
  204         401  
428              
429             #
430             # Character class
431             #
432 204         2386121 use vars qw(
433             $dot
434             $dot_s
435             $eD
436             $eS
437             $eW
438             $eH
439             $eV
440             $eR
441             $eN
442             $not_alnum
443             $not_alpha
444             $not_ascii
445             $not_blank
446             $not_cntrl
447             $not_digit
448             $not_graph
449             $not_lower
450             $not_lower_i
451             $not_print
452             $not_punct
453             $not_space
454             $not_upper
455             $not_upper_i
456             $not_word
457             $not_xdigit
458             $eb
459             $eB
460 204     204   1331 );
  204         372  
461              
462             ${Elatin2::dot} = qr{(?>[^\x0A])};
463             ${Elatin2::dot_s} = qr{(?>[\x00-\xFF])};
464             ${Elatin2::eD} = qr{(?>[^0-9])};
465              
466             # Vertical tabs are now whitespace
467             # \s in a regex now matches a vertical tab in all circumstances.
468             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
469             # ${Elatin2::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
470             # ${Elatin2::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
471             ${Elatin2::eS} = qr{(?>[^\s])};
472              
473             ${Elatin2::eW} = qr{(?>[^0-9A-Z_a-z])};
474             ${Elatin2::eH} = qr{(?>[^\x09\x20])};
475             ${Elatin2::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
476             ${Elatin2::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
477             ${Elatin2::eN} = qr{(?>[^\x0A])};
478             ${Elatin2::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
479             ${Elatin2::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
480             ${Elatin2::not_ascii} = qr{(?>[^\x00-\x7F])};
481             ${Elatin2::not_blank} = qr{(?>[^\x09\x20])};
482             ${Elatin2::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
483             ${Elatin2::not_digit} = qr{(?>[^\x30-\x39])};
484             ${Elatin2::not_graph} = qr{(?>[^\x21-\x7F])};
485             ${Elatin2::not_lower} = qr{(?>[^\x61-\x7A])};
486             ${Elatin2::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
487             # ${Elatin2::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
488             ${Elatin2::not_print} = qr{(?>[^\x20-\x7F])};
489             ${Elatin2::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
490             ${Elatin2::not_space} = qr{(?>[^\s\x0B])};
491             ${Elatin2::not_upper} = qr{(?>[^\x41-\x5A])};
492             ${Elatin2::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
493             # ${Elatin2::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
494             ${Elatin2::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
495             ${Elatin2::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
496             ${Elatin2::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))};
497             ${Elatin2::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]))};
498              
499             # avoid: Name "Elatin2::foo" used only once: possible typo at here.
500             ${Elatin2::dot} = ${Elatin2::dot};
501             ${Elatin2::dot_s} = ${Elatin2::dot_s};
502             ${Elatin2::eD} = ${Elatin2::eD};
503             ${Elatin2::eS} = ${Elatin2::eS};
504             ${Elatin2::eW} = ${Elatin2::eW};
505             ${Elatin2::eH} = ${Elatin2::eH};
506             ${Elatin2::eV} = ${Elatin2::eV};
507             ${Elatin2::eR} = ${Elatin2::eR};
508             ${Elatin2::eN} = ${Elatin2::eN};
509             ${Elatin2::not_alnum} = ${Elatin2::not_alnum};
510             ${Elatin2::not_alpha} = ${Elatin2::not_alpha};
511             ${Elatin2::not_ascii} = ${Elatin2::not_ascii};
512             ${Elatin2::not_blank} = ${Elatin2::not_blank};
513             ${Elatin2::not_cntrl} = ${Elatin2::not_cntrl};
514             ${Elatin2::not_digit} = ${Elatin2::not_digit};
515             ${Elatin2::not_graph} = ${Elatin2::not_graph};
516             ${Elatin2::not_lower} = ${Elatin2::not_lower};
517             ${Elatin2::not_lower_i} = ${Elatin2::not_lower_i};
518             ${Elatin2::not_print} = ${Elatin2::not_print};
519             ${Elatin2::not_punct} = ${Elatin2::not_punct};
520             ${Elatin2::not_space} = ${Elatin2::not_space};
521             ${Elatin2::not_upper} = ${Elatin2::not_upper};
522             ${Elatin2::not_upper_i} = ${Elatin2::not_upper_i};
523             ${Elatin2::not_word} = ${Elatin2::not_word};
524             ${Elatin2::not_xdigit} = ${Elatin2::not_xdigit};
525             ${Elatin2::eb} = ${Elatin2::eb};
526             ${Elatin2::eB} = ${Elatin2::eB};
527              
528             #
529             # Latin-2 split
530             #
531             sub Elatin2::split(;$$$) {
532              
533             # P.794 29.2.161. split
534             # in Chapter 29: Functions
535             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
536              
537             # P.951 split
538             # in Chapter 27: Functions
539             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
540              
541 0     0 0 0 my $pattern = $_[0];
542 0         0 my $string = $_[1];
543 0         0 my $limit = $_[2];
544              
545             # if $pattern is also omitted or is the literal space, " "
546 0 0       0 if (not defined $pattern) {
547 0         0 $pattern = ' ';
548             }
549              
550             # if $string is omitted, the function splits the $_ string
551 0 0       0 if (not defined $string) {
552 0 0       0 if (defined $_) {
553 0         0 $string = $_;
554             }
555             else {
556 0         0 $string = '';
557             }
558             }
559              
560 0         0 my @split = ();
561              
562             # when string is empty
563 0 0       0 if ($string eq '') {
    0          
564              
565             # resulting list value in list context
566 0 0       0 if (wantarray) {
567 0         0 return @split;
568             }
569              
570             # count of substrings in scalar context
571             else {
572 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
573 0         0 @_ = @split;
574 0         0 return scalar @_;
575             }
576             }
577              
578             # split's first argument is more consistently interpreted
579             #
580             # After some changes earlier in v5.17, split's behavior has been simplified:
581             # if the PATTERN argument evaluates to a string containing one space, it is
582             # treated the way that a literal string containing one space once was.
583             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
584              
585             # if $pattern is also omitted or is the literal space, " ", the function splits
586             # on whitespace, /\s+/, after skipping any leading whitespace
587             # (and so on)
588              
589             elsif ($pattern eq ' ') {
590 0 0       0 if (not defined $limit) {
591 0         0 return CORE::split(' ', $string);
592             }
593             else {
594 0         0 return CORE::split(' ', $string, $limit);
595             }
596             }
597              
598             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
599 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
600              
601             # a pattern capable of matching either the null string or something longer than the
602             # null string will split the value of $string into separate characters wherever it
603             # matches the null string between characters
604             # (and so on)
605              
606 0 0       0 if ('' =~ / \A $pattern \z /xms) {
607 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
608 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
609              
610             # P.1024 Appendix W.10 Multibyte Processing
611             # of ISBN 1-56592-224-7 CJKV Information Processing
612             # (and so on)
613              
614             # the //m modifier is assumed when you split on the pattern /^/
615             # (and so on)
616              
617             # V
618 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
619              
620             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
621             # is included in the resulting list, interspersed with the fields that are ordinarily returned
622             # (and so on)
623              
624 0         0 local $@;
625 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
626 0         0 push @split, CORE::eval('$' . $digit);
627             }
628             }
629             }
630              
631             else {
632 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
633              
634             # V
635 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
636 0         0 local $@;
637 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
638 0         0 push @split, CORE::eval('$' . $digit);
639             }
640             }
641             }
642             }
643              
644             elsif ($limit > 0) {
645 0 0       0 if ('' =~ / \A $pattern \z /xms) {
646 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
647 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
648              
649             # V
650 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
651 0         0 local $@;
652 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
653 0         0 push @split, CORE::eval('$' . $digit);
654             }
655             }
656             }
657             }
658             else {
659 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
660 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
661              
662             # V
663 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
664 0         0 local $@;
665 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
666 0         0 push @split, CORE::eval('$' . $digit);
667             }
668             }
669             }
670             }
671             }
672              
673 0 0       0 if (CORE::length($string) > 0) {
674 0         0 push @split, $string;
675             }
676              
677             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
678 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
679 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
680 0         0 pop @split;
681             }
682             }
683              
684             # resulting list value in list context
685 0 0       0 if (wantarray) {
686 0         0 return @split;
687             }
688              
689             # count of substrings in scalar context
690             else {
691 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
692 0         0 @_ = @split;
693 0         0 return scalar @_;
694             }
695             }
696              
697             #
698             # get last subexpression offsets
699             #
700             sub _last_subexpression_offsets {
701 0     0   0 my $pattern = $_[0];
702              
703             # remove comment
704 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
705              
706 0         0 my $modifier = '';
707 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
708 0         0 $modifier = $1;
709 0         0 $modifier =~ s/-[A-Za-z]*//;
710             }
711              
712             # with /x modifier
713 0         0 my @char = ();
714 0 0       0 if ($modifier =~ /x/oxms) {
715 0         0 @char = $pattern =~ /\G((?>
716             [^\\\#\[\(] |
717             \\ $q_char |
718             \# (?>[^\n]*) $ |
719             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
720             \(\? |
721             $q_char
722             ))/oxmsg;
723             }
724              
725             # without /x modifier
726             else {
727 0         0 @char = $pattern =~ /\G((?>
728             [^\\\[\(] |
729             \\ $q_char |
730             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
731             \(\? |
732             $q_char
733             ))/oxmsg;
734             }
735              
736 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
737             }
738              
739             #
740             # Latin-2 transliteration (tr///)
741             #
742             sub Elatin2::tr($$$$;$) {
743              
744 0     0 0 0 my $bind_operator = $_[1];
745 0         0 my $searchlist = $_[2];
746 0         0 my $replacementlist = $_[3];
747 0   0     0 my $modifier = $_[4] || '';
748              
749 0 0       0 if ($modifier =~ /r/oxms) {
750 0 0       0 if ($bind_operator =~ / !~ /oxms) {
751 0         0 croak "Using !~ with tr///r doesn't make sense";
752             }
753             }
754              
755 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
756 0         0 my @searchlist = _charlist_tr($searchlist);
757 0         0 my @replacementlist = _charlist_tr($replacementlist);
758              
759 0         0 my %tr = ();
760 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
761 0 0       0 if (not exists $tr{$searchlist[$i]}) {
762 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
763 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
764             }
765             elsif ($modifier =~ /d/oxms) {
766 0         0 $tr{$searchlist[$i]} = '';
767             }
768             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
769 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
770             }
771             else {
772 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
773             }
774             }
775             }
776              
777 0         0 my $tr = 0;
778 0         0 my $replaced = '';
779 0 0       0 if ($modifier =~ /c/oxms) {
780 0         0 while (defined(my $char = shift @char)) {
781 0 0       0 if (not exists $tr{$char}) {
782 0 0       0 if (defined $replacementlist[0]) {
783 0         0 $replaced .= $replacementlist[0];
784             }
785 0         0 $tr++;
786 0 0       0 if ($modifier =~ /s/oxms) {
787 0   0     0 while (@char and (not exists $tr{$char[0]})) {
788 0         0 shift @char;
789 0         0 $tr++;
790             }
791             }
792             }
793             else {
794 0         0 $replaced .= $char;
795             }
796             }
797             }
798             else {
799 0         0 while (defined(my $char = shift @char)) {
800 0 0       0 if (exists $tr{$char}) {
801 0         0 $replaced .= $tr{$char};
802 0         0 $tr++;
803 0 0       0 if ($modifier =~ /s/oxms) {
804 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
805 0         0 shift @char;
806 0         0 $tr++;
807             }
808             }
809             }
810             else {
811 0         0 $replaced .= $char;
812             }
813             }
814             }
815              
816 0 0       0 if ($modifier =~ /r/oxms) {
817 0         0 return $replaced;
818             }
819             else {
820 0         0 $_[0] = $replaced;
821 0 0       0 if ($bind_operator =~ / !~ /oxms) {
822 0         0 return not $tr;
823             }
824             else {
825 0         0 return $tr;
826             }
827             }
828             }
829              
830             #
831             # Latin-2 chop
832             #
833             sub Elatin2::chop(@) {
834              
835 0     0 0 0 my $chop;
836 0 0       0 if (@_ == 0) {
837 0         0 my @char = /\G (?>$q_char) /oxmsg;
838 0         0 $chop = pop @char;
839 0         0 $_ = join '', @char;
840             }
841             else {
842 0         0 for (@_) {
843 0         0 my @char = /\G (?>$q_char) /oxmsg;
844 0         0 $chop = pop @char;
845 0         0 $_ = join '', @char;
846             }
847             }
848 0         0 return $chop;
849             }
850              
851             #
852             # Latin-2 index by octet
853             #
854             sub Elatin2::index($$;$) {
855              
856 0     0 1 0 my($str,$substr,$position) = @_;
857 0   0     0 $position ||= 0;
858 0         0 my $pos = 0;
859              
860 0         0 while ($pos < CORE::length($str)) {
861 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
862 0 0       0 if ($pos >= $position) {
863 0         0 return $pos;
864             }
865             }
866 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
867 0         0 $pos += CORE::length($1);
868             }
869             else {
870 0         0 $pos += 1;
871             }
872             }
873 0         0 return -1;
874             }
875              
876             #
877             # Latin-2 reverse index
878             #
879             sub Elatin2::rindex($$;$) {
880              
881 0     0 0 0 my($str,$substr,$position) = @_;
882 0   0     0 $position ||= CORE::length($str) - 1;
883 0         0 my $pos = 0;
884 0         0 my $rindex = -1;
885              
886 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
887 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
888 0         0 $rindex = $pos;
889             }
890 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
891 0         0 $pos += CORE::length($1);
892             }
893             else {
894 0         0 $pos += 1;
895             }
896             }
897 0         0 return $rindex;
898             }
899              
900             #
901             # Latin-2 lower case first with parameter
902             #
903             sub Elatin2::lcfirst(@) {
904 0 0   0 0 0 if (@_) {
905 0         0 my $s = shift @_;
906 0 0 0     0 if (@_ and wantarray) {
907 0         0 return Elatin2::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
908             }
909             else {
910 0         0 return Elatin2::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
911             }
912             }
913             else {
914 0         0 return Elatin2::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
915             }
916             }
917              
918             #
919             # Latin-2 lower case first without parameter
920             #
921             sub Elatin2::lcfirst_() {
922 0     0 0 0 return Elatin2::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
923             }
924              
925             #
926             # Latin-2 lower case with parameter
927             #
928             sub Elatin2::lc(@) {
929 0 0   0 0 0 if (@_) {
930 0         0 my $s = shift @_;
931 0 0 0     0 if (@_ and wantarray) {
932 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
933             }
934             else {
935 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
936             }
937             }
938             else {
939 0         0 return Elatin2::lc_();
940             }
941             }
942              
943             #
944             # Latin-2 lower case without parameter
945             #
946             sub Elatin2::lc_() {
947 0     0 0 0 my $s = $_;
948 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
949             }
950              
951             #
952             # Latin-2 upper case first with parameter
953             #
954             sub Elatin2::ucfirst(@) {
955 0 0   0 0 0 if (@_) {
956 0         0 my $s = shift @_;
957 0 0 0     0 if (@_ and wantarray) {
958 0         0 return Elatin2::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
959             }
960             else {
961 0         0 return Elatin2::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
962             }
963             }
964             else {
965 0         0 return Elatin2::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
966             }
967             }
968              
969             #
970             # Latin-2 upper case first without parameter
971             #
972             sub Elatin2::ucfirst_() {
973 0     0 0 0 return Elatin2::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
974             }
975              
976             #
977             # Latin-2 upper case with parameter
978             #
979             sub Elatin2::uc(@) {
980 0 50   174 0 0 if (@_) {
981 174         267 my $s = shift @_;
982 174 50 33     231 if (@_ and wantarray) {
983 174 0       305 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
984             }
985             else {
986 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         556  
987             }
988             }
989             else {
990 174         620 return Elatin2::uc_();
991             }
992             }
993              
994             #
995             # Latin-2 upper case without parameter
996             #
997             sub Elatin2::uc_() {
998 0     0 0 0 my $s = $_;
999 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1000             }
1001              
1002             #
1003             # Latin-2 fold case with parameter
1004             #
1005             sub Elatin2::fc(@) {
1006 0 50   197 0 0 if (@_) {
1007 197         293 my $s = shift @_;
1008 197 50 33     229 if (@_ and wantarray) {
1009 197 0       327 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1010             }
1011             else {
1012 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         477  
1013             }
1014             }
1015             else {
1016 197         998 return Elatin2::fc_();
1017             }
1018             }
1019              
1020             #
1021             # Latin-2 fold case without parameter
1022             #
1023             sub Elatin2::fc_() {
1024 0     0 0 0 my $s = $_;
1025 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1026             }
1027              
1028             #
1029             # Latin-2 regexp capture
1030             #
1031             {
1032             sub Elatin2::capture {
1033 0     0 1 0 return $_[0];
1034             }
1035             }
1036              
1037             #
1038             # Latin-2 regexp ignore case modifier
1039             #
1040             sub Elatin2::ignorecase {
1041              
1042 0     0 0 0 my @string = @_;
1043 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1044              
1045             # ignore case of $scalar or @array
1046 0         0 for my $string (@string) {
1047              
1048             # split regexp
1049 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1050              
1051             # unescape character
1052 0         0 for (my $i=0; $i <= $#char; $i++) {
1053 0 0       0 next if not defined $char[$i];
1054              
1055             # open character class [...]
1056 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1057 0         0 my $left = $i;
1058              
1059             # [] make die "unmatched [] in regexp ...\n"
1060              
1061 0 0       0 if ($char[$i+1] eq ']') {
1062 0         0 $i++;
1063             }
1064              
1065 0         0 while (1) {
1066 0 0       0 if (++$i > $#char) {
1067 0         0 croak "Unmatched [] in regexp";
1068             }
1069 0 0       0 if ($char[$i] eq ']') {
1070 0         0 my $right = $i;
1071 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1072              
1073             # escape character
1074 0         0 for my $char (@charlist) {
1075 0 0       0 if (0) {
1076             }
1077              
1078 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1079 0         0 $char = '\\' . $char;
1080             }
1081             }
1082              
1083             # [...]
1084 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1085              
1086 0         0 $i = $left;
1087 0         0 last;
1088             }
1089             }
1090             }
1091              
1092             # open character class [^...]
1093             elsif ($char[$i] eq '[^') {
1094 0         0 my $left = $i;
1095              
1096             # [^] make die "unmatched [] in regexp ...\n"
1097              
1098 0 0       0 if ($char[$i+1] eq ']') {
1099 0         0 $i++;
1100             }
1101              
1102 0         0 while (1) {
1103 0 0       0 if (++$i > $#char) {
1104 0         0 croak "Unmatched [] in regexp";
1105             }
1106 0 0       0 if ($char[$i] eq ']') {
1107 0         0 my $right = $i;
1108 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1109              
1110             # escape character
1111 0         0 for my $char (@charlist) {
1112 0 0       0 if (0) {
1113             }
1114              
1115 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1116 0         0 $char = '\\' . $char;
1117             }
1118             }
1119              
1120             # [^...]
1121 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1122              
1123 0         0 $i = $left;
1124 0         0 last;
1125             }
1126             }
1127             }
1128              
1129             # rewrite classic character class or escape character
1130             elsif (my $char = classic_character_class($char[$i])) {
1131 0         0 $char[$i] = $char;
1132             }
1133              
1134             # with /i modifier
1135             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1136 0         0 my $uc = Elatin2::uc($char[$i]);
1137 0         0 my $fc = Elatin2::fc($char[$i]);
1138 0 0       0 if ($uc ne $fc) {
1139 0 0       0 if (CORE::length($fc) == 1) {
1140 0         0 $char[$i] = '[' . $uc . $fc . ']';
1141             }
1142             else {
1143 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1144             }
1145             }
1146             }
1147             }
1148              
1149             # characterize
1150 0         0 for (my $i=0; $i <= $#char; $i++) {
1151 0 0       0 next if not defined $char[$i];
1152              
1153 0 0       0 if (0) {
1154             }
1155              
1156             # quote character before ? + * {
1157 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1158 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1159 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1160             }
1161             }
1162             }
1163              
1164 0         0 $string = join '', @char;
1165             }
1166              
1167             # make regexp string
1168 0         0 return @string;
1169             }
1170              
1171             #
1172             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1173             #
1174             sub Elatin2::classic_character_class {
1175 0     1867 0 0 my($char) = @_;
1176              
1177             return {
1178             '\D' => '${Elatin2::eD}',
1179             '\S' => '${Elatin2::eS}',
1180             '\W' => '${Elatin2::eW}',
1181             '\d' => '[0-9]',
1182              
1183             # Before Perl 5.6, \s only matched the five whitespace characters
1184             # tab, newline, form-feed, carriage return, and the space character
1185             # itself, which, taken together, is the character class [\t\n\f\r ].
1186              
1187             # Vertical tabs are now whitespace
1188             # \s in a regex now matches a vertical tab in all circumstances.
1189             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1190             # \t \n \v \f \r space
1191             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1192             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1193             '\s' => '\s',
1194              
1195             '\w' => '[0-9A-Z_a-z]',
1196             '\C' => '[\x00-\xFF]',
1197             '\X' => 'X',
1198              
1199             # \h \v \H \V
1200              
1201             # P.114 Character Class Shortcuts
1202             # in Chapter 7: In the World of Regular Expressions
1203             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1204              
1205             # P.357 13.2.3 Whitespace
1206             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1207             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1208             #
1209             # 0x00009 CHARACTER TABULATION h s
1210             # 0x0000a LINE FEED (LF) vs
1211             # 0x0000b LINE TABULATION v
1212             # 0x0000c FORM FEED (FF) vs
1213             # 0x0000d CARRIAGE RETURN (CR) vs
1214             # 0x00020 SPACE h s
1215              
1216             # P.196 Table 5-9. Alphanumeric regex metasymbols
1217             # in Chapter 5. Pattern Matching
1218             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1219              
1220             # (and so on)
1221              
1222             '\H' => '${Elatin2::eH}',
1223             '\V' => '${Elatin2::eV}',
1224             '\h' => '[\x09\x20]',
1225             '\v' => '[\x0A\x0B\x0C\x0D]',
1226             '\R' => '${Elatin2::eR}',
1227              
1228             # \N
1229             #
1230             # http://perldoc.perl.org/perlre.html
1231             # Character Classes and other Special Escapes
1232             # Any character but \n (experimental). Not affected by /s modifier
1233              
1234             '\N' => '${Elatin2::eN}',
1235              
1236             # \b \B
1237              
1238             # P.180 Boundaries: The \b and \B Assertions
1239             # in Chapter 5: Pattern Matching
1240             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1241              
1242             # P.219 Boundaries: The \b and \B Assertions
1243             # in Chapter 5: Pattern Matching
1244             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1245              
1246             # \b really means (?:(?<=\w)(?!\w)|(?
1247             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1248             '\b' => '${Elatin2::eb}',
1249              
1250             # \B really means (?:(?<=\w)(?=\w)|(?
1251             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1252             '\B' => '${Elatin2::eB}',
1253              
1254 1867   100     2724 }->{$char} || '';
1255             }
1256              
1257             #
1258             # prepare Latin-2 characters per length
1259             #
1260              
1261             # 1 octet characters
1262             my @chars1 = ();
1263             sub chars1 {
1264 1867 0   0 0 71846 if (@chars1) {
1265 0         0 return @chars1;
1266             }
1267 0 0       0 if (exists $range_tr{1}) {
1268 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1269 0         0 while (my @range = splice(@ranges,0,1)) {
1270 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1271 0         0 push @chars1, pack 'C', $oct0;
1272             }
1273             }
1274             }
1275 0         0 return @chars1;
1276             }
1277              
1278             # 2 octets characters
1279             my @chars2 = ();
1280             sub chars2 {
1281 0 0   0 0 0 if (@chars2) {
1282 0         0 return @chars2;
1283             }
1284 0 0       0 if (exists $range_tr{2}) {
1285 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1286 0         0 while (my @range = splice(@ranges,0,2)) {
1287 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1288 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1289 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1290             }
1291             }
1292             }
1293             }
1294 0         0 return @chars2;
1295             }
1296              
1297             # 3 octets characters
1298             my @chars3 = ();
1299             sub chars3 {
1300 0 0   0 0 0 if (@chars3) {
1301 0         0 return @chars3;
1302             }
1303 0 0       0 if (exists $range_tr{3}) {
1304 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1305 0         0 while (my @range = splice(@ranges,0,3)) {
1306 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1307 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1308 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1309 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1310             }
1311             }
1312             }
1313             }
1314             }
1315 0         0 return @chars3;
1316             }
1317              
1318             # 4 octets characters
1319             my @chars4 = ();
1320             sub chars4 {
1321 0 0   0 0 0 if (@chars4) {
1322 0         0 return @chars4;
1323             }
1324 0 0       0 if (exists $range_tr{4}) {
1325 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1326 0         0 while (my @range = splice(@ranges,0,4)) {
1327 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1328 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1329 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1330 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1331 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1332             }
1333             }
1334             }
1335             }
1336             }
1337             }
1338 0         0 return @chars4;
1339             }
1340              
1341             #
1342             # Latin-2 open character list for tr
1343             #
1344             sub _charlist_tr {
1345              
1346 0     0   0 local $_ = shift @_;
1347              
1348             # unescape character
1349 0         0 my @char = ();
1350 0         0 while (not /\G \z/oxmsgc) {
1351 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1352 0         0 push @char, '\-';
1353             }
1354             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1355 0         0 push @char, CORE::chr(oct $1);
1356             }
1357             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1358 0         0 push @char, CORE::chr(hex $1);
1359             }
1360             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1361 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1362             }
1363             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1364             push @char, {
1365             '\0' => "\0",
1366             '\n' => "\n",
1367             '\r' => "\r",
1368             '\t' => "\t",
1369             '\f' => "\f",
1370             '\b' => "\x08", # \b means backspace in character class
1371             '\a' => "\a",
1372             '\e' => "\e",
1373 0         0 }->{$1};
1374             }
1375             elsif (/\G \\ ($q_char) /oxmsgc) {
1376 0         0 push @char, $1;
1377             }
1378             elsif (/\G ($q_char) /oxmsgc) {
1379 0         0 push @char, $1;
1380             }
1381             }
1382              
1383             # join separated multiple-octet
1384 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1385              
1386             # unescape '-'
1387 0         0 my @i = ();
1388 0         0 for my $i (0 .. $#char) {
1389 0 0       0 if ($char[$i] eq '\-') {
    0          
1390 0         0 $char[$i] = '-';
1391             }
1392             elsif ($char[$i] eq '-') {
1393 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1394 0         0 push @i, $i;
1395             }
1396             }
1397             }
1398              
1399             # open character list (reverse for splice)
1400 0         0 for my $i (CORE::reverse @i) {
1401 0         0 my @range = ();
1402              
1403             # range error
1404 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1405 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1406             }
1407              
1408             # range of multiple-octet code
1409 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1410 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1411 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1412             }
1413             elsif (CORE::length($char[$i+1]) == 2) {
1414 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1415 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1416             }
1417             elsif (CORE::length($char[$i+1]) == 3) {
1418 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1419 0         0 push @range, chars2();
1420 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1421             }
1422             elsif (CORE::length($char[$i+1]) == 4) {
1423 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1424 0         0 push @range, chars2();
1425 0         0 push @range, chars3();
1426 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1427             }
1428             else {
1429 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1430             }
1431             }
1432             elsif (CORE::length($char[$i-1]) == 2) {
1433 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1434 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1435             }
1436             elsif (CORE::length($char[$i+1]) == 3) {
1437 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1438 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1439             }
1440             elsif (CORE::length($char[$i+1]) == 4) {
1441 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1442 0         0 push @range, chars3();
1443 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1444             }
1445             else {
1446 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1447             }
1448             }
1449             elsif (CORE::length($char[$i-1]) == 3) {
1450 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1451 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1452             }
1453             elsif (CORE::length($char[$i+1]) == 4) {
1454 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1455 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1456             }
1457             else {
1458 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1459             }
1460             }
1461             elsif (CORE::length($char[$i-1]) == 4) {
1462 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1463 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1464             }
1465             else {
1466 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1467             }
1468             }
1469             else {
1470 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1471             }
1472              
1473 0         0 splice @char, $i-1, 3, @range;
1474             }
1475              
1476 0         0 return @char;
1477             }
1478              
1479             #
1480             # Latin-2 open character class
1481             #
1482             sub _cc {
1483 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1484 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1485             }
1486             elsif (scalar(@_) == 1) {
1487 0         0 return sprintf('\x%02X',$_[0]);
1488             }
1489             elsif (scalar(@_) == 2) {
1490 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1491 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1492             }
1493             elsif ($_[0] == $_[1]) {
1494 0         0 return sprintf('\x%02X',$_[0]);
1495             }
1496             elsif (($_[0]+1) == $_[1]) {
1497 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1498             }
1499             else {
1500 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1501             }
1502             }
1503             else {
1504 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1505             }
1506             }
1507              
1508             #
1509             # Latin-2 octet range
1510             #
1511             sub _octets {
1512 0     182   0 my $length = shift @_;
1513              
1514 182 50       341 if ($length == 1) {
1515 182         391 my($a1) = unpack 'C', $_[0];
1516 182         499 my($z1) = unpack 'C', $_[1];
1517              
1518 182 50       325 if ($a1 > $z1) {
1519 182         459 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1520             }
1521              
1522 0 50       0 if ($a1 == $z1) {
    50          
1523 182         600 return sprintf('\x%02X',$a1);
1524             }
1525             elsif (($a1+1) == $z1) {
1526 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1527             }
1528             else {
1529 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1530             }
1531             }
1532             else {
1533 182         1265 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1534             }
1535             }
1536              
1537             #
1538             # Latin-2 range regexp
1539             #
1540             sub _range_regexp {
1541 0     182   0 my($length,$first,$last) = @_;
1542              
1543 182         394 my @range_regexp = ();
1544 182 50       253 if (not exists $range_tr{$length}) {
1545 182         476 return @range_regexp;
1546             }
1547              
1548 0         0 my @ranges = @{ $range_tr{$length} };
  182         308  
1549 182         410 while (my @range = splice(@ranges,0,$length)) {
1550 182         587 my $min = '';
1551 182         301 my $max = '';
1552 182         223 for (my $i=0; $i < $length; $i++) {
1553 182         530 $min .= pack 'C', $range[$i][0];
1554 182         807 $max .= pack 'C', $range[$i][-1];
1555             }
1556              
1557             # min___max
1558             # FIRST_____________LAST
1559             # (nothing)
1560              
1561 182 50 33     639 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1562             }
1563              
1564             # **********
1565             # min_________max
1566             # FIRST_____________LAST
1567             # **********
1568              
1569             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1570 182         1960 push @range_regexp, _octets($length,$first,$max,$min,$max);
1571             }
1572              
1573             # **********************
1574             # min________________max
1575             # FIRST_____________LAST
1576             # **********************
1577              
1578             elsif (($min eq $first) and ($max eq $last)) {
1579 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1580             }
1581              
1582             # *********
1583             # min___max
1584             # FIRST_____________LAST
1585             # *********
1586              
1587             elsif (($first le $min) and ($max le $last)) {
1588 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1589             }
1590              
1591             # **********************
1592             # min__________________________max
1593             # FIRST_____________LAST
1594             # **********************
1595              
1596             elsif (($min le $first) and ($last le $max)) {
1597 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1598             }
1599              
1600             # *********
1601             # min________max
1602             # FIRST_____________LAST
1603             # *********
1604              
1605             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1606 182         476 push @range_regexp, _octets($length,$min,$last,$min,$max);
1607             }
1608              
1609             # min___max
1610             # FIRST_____________LAST
1611             # (nothing)
1612              
1613             elsif ($last lt $min) {
1614             }
1615              
1616             else {
1617 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1618             }
1619             }
1620              
1621 0         0 return @range_regexp;
1622             }
1623              
1624             #
1625             # Latin-2 open character list for qr and not qr
1626             #
1627             sub _charlist {
1628              
1629 182     358   398 my $modifier = pop @_;
1630 358         550 my @char = @_;
1631              
1632 358 100       735 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1633              
1634             # unescape character
1635 358         801 for (my $i=0; $i <= $#char; $i++) {
1636              
1637             # escape - to ...
1638 358 100 100     1371 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1639 1125 100 100     8317 if ((0 < $i) and ($i < $#char)) {
1640 206         816 $char[$i] = '...';
1641             }
1642             }
1643              
1644             # octal escape sequence
1645             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1646 182         387 $char[$i] = octchr($1);
1647             }
1648              
1649             # hexadecimal escape sequence
1650             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1651 0         0 $char[$i] = hexchr($1);
1652             }
1653              
1654             # \b{...} --> b\{...}
1655             # \B{...} --> B\{...}
1656             # \N{CHARNAME} --> N\{CHARNAME}
1657             # \p{PROPERTY} --> p\{PROPERTY}
1658             # \P{PROPERTY} --> P\{PROPERTY}
1659             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1660 0         0 $char[$i] = $1 . '\\' . $2;
1661             }
1662              
1663             # \p, \P, \X --> p, P, X
1664             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1665 0         0 $char[$i] = $1;
1666             }
1667              
1668             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1669 0         0 $char[$i] = CORE::chr oct $1;
1670             }
1671             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1672 0         0 $char[$i] = CORE::chr hex $1;
1673             }
1674             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1675 22         104 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1676             }
1677             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1678             $char[$i] = {
1679             '\0' => "\0",
1680             '\n' => "\n",
1681             '\r' => "\r",
1682             '\t' => "\t",
1683             '\f' => "\f",
1684             '\b' => "\x08", # \b means backspace in character class
1685             '\a' => "\a",
1686             '\e' => "\e",
1687             '\d' => '[0-9]',
1688              
1689             # Vertical tabs are now whitespace
1690             # \s in a regex now matches a vertical tab in all circumstances.
1691             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1692             # \t \n \v \f \r space
1693             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1694             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1695             '\s' => '\s',
1696              
1697             '\w' => '[0-9A-Z_a-z]',
1698             '\D' => '${Elatin2::eD}',
1699             '\S' => '${Elatin2::eS}',
1700             '\W' => '${Elatin2::eW}',
1701              
1702             '\H' => '${Elatin2::eH}',
1703             '\V' => '${Elatin2::eV}',
1704             '\h' => '[\x09\x20]',
1705             '\v' => '[\x0A\x0B\x0C\x0D]',
1706             '\R' => '${Elatin2::eR}',
1707              
1708 0         0 }->{$1};
1709             }
1710              
1711             # POSIX-style character classes
1712             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1713             $char[$i] = {
1714              
1715             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1716             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1717             '[:^lower:]' => '${Elatin2::not_lower_i}',
1718             '[:^upper:]' => '${Elatin2::not_upper_i}',
1719              
1720 25         405 }->{$1};
1721             }
1722             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1723             $char[$i] = {
1724              
1725             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1726             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1727             '[:ascii:]' => '[\x00-\x7F]',
1728             '[:blank:]' => '[\x09\x20]',
1729             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1730             '[:digit:]' => '[\x30-\x39]',
1731             '[:graph:]' => '[\x21-\x7F]',
1732             '[:lower:]' => '[\x61-\x7A]',
1733             '[:print:]' => '[\x20-\x7F]',
1734             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1735              
1736             # P.174 POSIX-Style Character Classes
1737             # in Chapter 5: Pattern Matching
1738             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1739              
1740             # P.311 11.2.4 Character Classes and other Special Escapes
1741             # in Chapter 11: perlre: Perl regular expressions
1742             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1743              
1744             # P.210 POSIX-Style Character Classes
1745             # in Chapter 5: Pattern Matching
1746             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1747              
1748             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1749              
1750             '[:upper:]' => '[\x41-\x5A]',
1751             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1752             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1753             '[:^alnum:]' => '${Elatin2::not_alnum}',
1754             '[:^alpha:]' => '${Elatin2::not_alpha}',
1755             '[:^ascii:]' => '${Elatin2::not_ascii}',
1756             '[:^blank:]' => '${Elatin2::not_blank}',
1757             '[:^cntrl:]' => '${Elatin2::not_cntrl}',
1758             '[:^digit:]' => '${Elatin2::not_digit}',
1759             '[:^graph:]' => '${Elatin2::not_graph}',
1760             '[:^lower:]' => '${Elatin2::not_lower}',
1761             '[:^print:]' => '${Elatin2::not_print}',
1762             '[:^punct:]' => '${Elatin2::not_punct}',
1763             '[:^space:]' => '${Elatin2::not_space}',
1764             '[:^upper:]' => '${Elatin2::not_upper}',
1765             '[:^word:]' => '${Elatin2::not_word}',
1766             '[:^xdigit:]' => '${Elatin2::not_xdigit}',
1767              
1768 8         53 }->{$1};
1769             }
1770             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1771 70         1264 $char[$i] = $1;
1772             }
1773             }
1774              
1775             # open character list
1776 7         36 my @singleoctet = ();
1777 358         738 my @multipleoctet = ();
1778 358         507 for (my $i=0; $i <= $#char; ) {
1779              
1780             # escaped -
1781 358 100 100     876 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1782 943         3807 $i += 1;
1783 182         229 next;
1784             }
1785              
1786             # make range regexp
1787             elsif ($char[$i] eq '...') {
1788              
1789             # range error
1790 182 50       329 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1791 182         704 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1792             }
1793             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1794 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1795 182         510 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1796             }
1797             }
1798              
1799             # make range regexp per length
1800 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1801 182         533 my @regexp = ();
1802              
1803             # is first and last
1804 182 50 33     249 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1805 182         756 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1806             }
1807              
1808             # is first
1809             elsif ($length == CORE::length($char[$i-1])) {
1810 182         488 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1811             }
1812              
1813             # is inside in first and last
1814             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1815 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1816             }
1817              
1818             # is last
1819             elsif ($length == CORE::length($char[$i+1])) {
1820 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1821             }
1822              
1823             else {
1824 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1825             }
1826              
1827 0 50       0 if ($length == 1) {
1828 182         368 push @singleoctet, @regexp;
1829             }
1830             else {
1831 182         476 push @multipleoctet, @regexp;
1832             }
1833             }
1834              
1835 0         0 $i += 2;
1836             }
1837              
1838             # with /i modifier
1839             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1840 182 100       452 if ($modifier =~ /i/oxms) {
1841 493         703 my $uc = Elatin2::uc($char[$i]);
1842 24         47 my $fc = Elatin2::fc($char[$i]);
1843 24 100       57 if ($uc ne $fc) {
1844 24 50       42 if (CORE::length($fc) == 1) {
1845 12         25 push @singleoctet, $uc, $fc;
1846             }
1847             else {
1848 12         16 push @singleoctet, $uc;
1849 0         0 push @multipleoctet, $fc;
1850             }
1851             }
1852             else {
1853 0         0 push @singleoctet, $char[$i];
1854             }
1855             }
1856             else {
1857 12         30 push @singleoctet, $char[$i];
1858             }
1859 469         694 $i += 1;
1860             }
1861              
1862             # single character of single octet code
1863             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1864 493         804 push @singleoctet, "\t", "\x20";
1865 0         0 $i += 1;
1866             }
1867             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1868 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1869 0         0 $i += 1;
1870             }
1871             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1872 0         0 push @singleoctet, $char[$i];
1873 2         5 $i += 1;
1874             }
1875              
1876             # single character of multiple-octet code
1877             else {
1878 2         11 push @multipleoctet, $char[$i];
1879 84         162 $i += 1;
1880             }
1881             }
1882              
1883             # quote metachar
1884 84         152 for (@singleoctet) {
1885 358 50       724 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1886 689         3057 $_ = '-';
1887             }
1888             elsif (/\A \n \z/oxms) {
1889 0         0 $_ = '\n';
1890             }
1891             elsif (/\A \r \z/oxms) {
1892 8         24 $_ = '\r';
1893             }
1894             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1895 8         21 $_ = sprintf('\x%02X', CORE::ord $1);
1896             }
1897             elsif (/\A [\x00-\xFF] \z/oxms) {
1898 60         186 $_ = quotemeta $_;
1899             }
1900             }
1901              
1902             # return character list
1903 429         682 return \@singleoctet, \@multipleoctet;
1904             }
1905              
1906             #
1907             # Latin-2 octal escape sequence
1908             #
1909             sub octchr {
1910 358     5 0 1211 my($octdigit) = @_;
1911              
1912 5         15 my @binary = ();
1913 5         7 for my $octal (split(//,$octdigit)) {
1914             push @binary, {
1915             '0' => '000',
1916             '1' => '001',
1917             '2' => '010',
1918             '3' => '011',
1919             '4' => '100',
1920             '5' => '101',
1921             '6' => '110',
1922             '7' => '111',
1923 5         20 }->{$octal};
1924             }
1925 50         173 my $binary = join '', @binary;
1926              
1927             my $octchr = {
1928             # 1234567
1929             1 => pack('B*', "0000000$binary"),
1930             2 => pack('B*', "000000$binary"),
1931             3 => pack('B*', "00000$binary"),
1932             4 => pack('B*', "0000$binary"),
1933             5 => pack('B*', "000$binary"),
1934             6 => pack('B*', "00$binary"),
1935             7 => pack('B*', "0$binary"),
1936             0 => pack('B*', "$binary"),
1937              
1938 5         13 }->{CORE::length($binary) % 8};
1939              
1940 5         64 return $octchr;
1941             }
1942              
1943             #
1944             # Latin-2 hexadecimal escape sequence
1945             #
1946             sub hexchr {
1947 5     5 0 19 my($hexdigit) = @_;
1948              
1949             my $hexchr = {
1950             1 => pack('H*', "0$hexdigit"),
1951             0 => pack('H*', "$hexdigit"),
1952              
1953 5         16 }->{CORE::length($_[0]) % 2};
1954              
1955 5         153 return $hexchr;
1956             }
1957              
1958             #
1959             # Latin-2 open character list for qr
1960             #
1961             sub charlist_qr {
1962              
1963 5     314 0 23 my $modifier = pop @_;
1964 314         630 my @char = @_;
1965              
1966 314         749 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1967 314         960 my @singleoctet = @$singleoctet;
1968 314         660 my @multipleoctet = @$multipleoctet;
1969              
1970             # return character list
1971 314 100       550 if (scalar(@singleoctet) >= 1) {
1972              
1973             # with /i modifier
1974 314 100       691 if ($modifier =~ m/i/oxms) {
1975 236         530 my %singleoctet_ignorecase = ();
1976 22         33 for (@singleoctet) {
1977 22   100     39 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1978 46         199 for my $ord (hex($1) .. hex($2)) {
1979 46         136 my $char = CORE::chr($ord);
1980 66         95 my $uc = Elatin2::uc($char);
1981 66         109 my $fc = Elatin2::fc($char);
1982 66 100       114 if ($uc eq $fc) {
1983 66         122 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1984             }
1985             else {
1986 12 50       82 if (CORE::length($fc) == 1) {
1987 54         82 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1988 54         119 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1989             }
1990             else {
1991 54         183 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1992 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1993             }
1994             }
1995             }
1996             }
1997 0 50       0 if ($_ ne '') {
1998 46         97 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1999             }
2000             }
2001 0         0 my $i = 0;
2002 22         33 my @singleoctet_ignorecase = ();
2003 22         28 for my $ord (0 .. 255) {
2004 22 100       39 if (exists $singleoctet_ignorecase{$ord}) {
2005 5632         6523 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         94  
2006             }
2007             else {
2008 96         223 $i++;
2009             }
2010             }
2011 5536         5537 @singleoctet = ();
2012 22         35 for my $range (@singleoctet_ignorecase) {
2013 22 100       64 if (ref $range) {
2014 3648 100       5801 if (scalar(@{$range}) == 1) {
  56 50       57  
2015 56         89 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         43  
2016             }
2017 36         133 elsif (scalar(@{$range}) == 2) {
2018 20         23 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2019             }
2020             else {
2021 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         28  
  20         25  
2022             }
2023             }
2024             }
2025             }
2026              
2027 20         74 my $not_anchor = '';
2028              
2029 236         380 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2030             }
2031 236 100       639 if (scalar(@multipleoctet) >= 2) {
2032 314         631 return '(?:' . join('|', @multipleoctet) . ')';
2033             }
2034             else {
2035 6         40 return $multipleoctet[0];
2036             }
2037             }
2038              
2039             #
2040             # Latin-2 open character list for not qr
2041             #
2042             sub charlist_not_qr {
2043              
2044 308     44 0 1262 my $modifier = pop @_;
2045 44         116 my @char = @_;
2046              
2047 44         102 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2048 44         121 my @singleoctet = @$singleoctet;
2049 44         108 my @multipleoctet = @$multipleoctet;
2050              
2051             # with /i modifier
2052 44 100       69 if ($modifier =~ m/i/oxms) {
2053 44         99 my %singleoctet_ignorecase = ();
2054 10         17 for (@singleoctet) {
2055 10   66     16 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2056 10         44 for my $ord (hex($1) .. hex($2)) {
2057 10         34 my $char = CORE::chr($ord);
2058 30         76 my $uc = Elatin2::uc($char);
2059 30         43 my $fc = Elatin2::fc($char);
2060 30 50       49 if ($uc eq $fc) {
2061 30         48 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2062             }
2063             else {
2064 0 50       0 if (CORE::length($fc) == 1) {
2065 30         42 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2066 30         55 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2067             }
2068             else {
2069 30         88 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2070 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2071             }
2072             }
2073             }
2074             }
2075 0 50       0 if ($_ ne '') {
2076 10         30 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2077             }
2078             }
2079 0         0 my $i = 0;
2080 10         14 my @singleoctet_ignorecase = ();
2081 10         17 for my $ord (0 .. 255) {
2082 10 100       45 if (exists $singleoctet_ignorecase{$ord}) {
2083 2560         2913 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         54  
2084             }
2085             else {
2086 60         106 $i++;
2087             }
2088             }
2089 2500         2430 @singleoctet = ();
2090 10         17 for my $range (@singleoctet_ignorecase) {
2091 10 100       27 if (ref $range) {
2092 960 50       1414 if (scalar(@{$range}) == 1) {
  20 50       22  
2093 20         30 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2094             }
2095 0         0 elsif (scalar(@{$range}) == 2) {
2096 20         27 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2097             }
2098             else {
2099 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         24  
  20         23  
2100             }
2101             }
2102             }
2103             }
2104              
2105             # return character list
2106 20 50       71 if (scalar(@multipleoctet) >= 1) {
2107 44 0       108 if (scalar(@singleoctet) >= 1) {
2108              
2109             # any character other than multiple-octet and single octet character class
2110 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2111             }
2112             else {
2113              
2114             # any character other than multiple-octet character class
2115 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2116             }
2117             }
2118             else {
2119 0 50       0 if (scalar(@singleoctet) >= 1) {
2120              
2121             # any character other than single octet character class
2122 44         79 return '(?:[^' . join('', @singleoctet) . '])';
2123             }
2124             else {
2125              
2126             # any character
2127 44         252 return "(?:$your_char)";
2128             }
2129             }
2130             }
2131              
2132             #
2133             # open file in read mode
2134             #
2135             sub _open_r {
2136 0     408   0 my(undef,$file) = @_;
2137 204     204   2606 use Fcntl qw(O_RDONLY);
  204         698  
  204         34803  
2138 408         1214 return CORE::sysopen($_[0], $file, &O_RDONLY);
2139             }
2140              
2141             #
2142             # open file in append mode
2143             #
2144             sub _open_a {
2145 408     204   19107 my(undef,$file) = @_;
2146 204     204   1577 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         454  
  204         723997  
2147 204         643 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2148             }
2149              
2150             #
2151             # safe system
2152             #
2153             sub _systemx {
2154              
2155             # P.707 29.2.33. exec
2156             # in Chapter 29: Functions
2157             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2158             #
2159             # Be aware that in older releases of Perl, exec (and system) did not flush
2160             # your output buffer, so you needed to enable command buffering by setting $|
2161             # on one or more filehandles to avoid lost output in the case of exec, or
2162             # misordererd output in the case of system. This situation was largely remedied
2163             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2164              
2165             # P.855 exec
2166             # in Chapter 27: Functions
2167             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2168             #
2169             # In very old release of Perl (before v5.6), exec (and system) did not flush
2170             # your output buffer, so you needed to enable command buffering by setting $|
2171             # on one or more filehandles to avoid lost output with exec or misordered
2172             # output with system.
2173              
2174 204     204   103882 $| = 1;
2175              
2176             # P.565 23.1.2. Cleaning Up Your Environment
2177             # in Chapter 23: Security
2178             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2179              
2180             # P.656 Cleaning Up Your Environment
2181             # in Chapter 20: Security
2182             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2183              
2184             # local $ENV{'PATH'} = '.';
2185 204         939 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2186              
2187             # P.707 29.2.33. exec
2188             # in Chapter 29: Functions
2189             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2190             #
2191             # As we mentioned earlier, exec treats a discrete list of arguments as an
2192             # indication that it should bypass shell processing. However, there is one
2193             # place where you might still get tripped up. The exec call (and system, too)
2194             # will not distinguish between a single scalar argument and an array containing
2195             # only one element.
2196             #
2197             # @args = ("echo surprise"); # just one element in list
2198             # exec @args # still subject to shell escapes
2199             # or die "exec: $!"; # because @args == 1
2200             #
2201             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2202             # first argument as the pathname, which forces the rest of the arguments to be
2203             # interpreted as a list, even if there is only one of them:
2204             #
2205             # exec { $args[0] } @args # safe even with one-argument list
2206             # or die "can't exec @args: $!";
2207              
2208             # P.855 exec
2209             # in Chapter 27: Functions
2210             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2211             #
2212             # As we mentioned earlier, exec treats a discrete list of arguments as a
2213             # directive to bypass shell processing. However, there is one place where
2214             # you might still get tripped up. The exec call (and system, too) cannot
2215             # distinguish between a single scalar argument and an array containing
2216             # only one element.
2217             #
2218             # @args = ("echo surprise"); # just one element in list
2219             # exec @args # still subject to shell escapes
2220             # || die "exec: $!"; # because @args == 1
2221             #
2222             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2223             # argument as the pathname, which forces the rest of the arguments to be
2224             # interpreted as a list, even if there is only one of them:
2225             #
2226             # exec { $args[0] } @args # safe even with one-argument list
2227             # || die "can't exec @args: $!";
2228              
2229 204         2021 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         498  
2230             }
2231              
2232             #
2233             # Latin-2 order to character (with parameter)
2234             #
2235             sub Elatin2::chr(;$) {
2236              
2237 204 0   0 0 21033218 my $c = @_ ? $_[0] : $_;
2238              
2239 0 0       0 if ($c == 0x00) {
2240 0         0 return "\x00";
2241             }
2242             else {
2243 0         0 my @chr = ();
2244 0         0 while ($c > 0) {
2245 0         0 unshift @chr, ($c % 0x100);
2246 0         0 $c = int($c / 0x100);
2247             }
2248 0         0 return pack 'C*', @chr;
2249             }
2250             }
2251              
2252             #
2253             # Latin-2 order to character (without parameter)
2254             #
2255             sub Elatin2::chr_() {
2256              
2257 0     0 0 0 my $c = $_;
2258              
2259 0 0       0 if ($c == 0x00) {
2260 0         0 return "\x00";
2261             }
2262             else {
2263 0         0 my @chr = ();
2264 0         0 while ($c > 0) {
2265 0         0 unshift @chr, ($c % 0x100);
2266 0         0 $c = int($c / 0x100);
2267             }
2268 0         0 return pack 'C*', @chr;
2269             }
2270             }
2271              
2272             #
2273             # Latin-2 path globbing (with parameter)
2274             #
2275             sub Elatin2::glob($) {
2276              
2277 0 0   0 0 0 if (wantarray) {
2278 0         0 my @glob = _DOS_like_glob(@_);
2279 0         0 for my $glob (@glob) {
2280 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2281             }
2282 0         0 return @glob;
2283             }
2284             else {
2285 0         0 my $glob = _DOS_like_glob(@_);
2286 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2287 0         0 return $glob;
2288             }
2289             }
2290              
2291             #
2292             # Latin-2 path globbing (without parameter)
2293             #
2294             sub Elatin2::glob_() {
2295              
2296 0 0   0 0 0 if (wantarray) {
2297 0         0 my @glob = _DOS_like_glob();
2298 0         0 for my $glob (@glob) {
2299 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2300             }
2301 0         0 return @glob;
2302             }
2303             else {
2304 0         0 my $glob = _DOS_like_glob();
2305 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2306 0         0 return $glob;
2307             }
2308             }
2309              
2310             #
2311             # Latin-2 path globbing via File::DosGlob 1.10
2312             #
2313             # Often I confuse "_dosglob" and "_doglob".
2314             # So, I renamed "_dosglob" to "_DOS_like_glob".
2315             #
2316             my %iter;
2317             my %entries;
2318             sub _DOS_like_glob {
2319              
2320             # context (keyed by second cxix argument provided by core)
2321 0     0   0 my($expr,$cxix) = @_;
2322              
2323             # glob without args defaults to $_
2324 0 0       0 $expr = $_ if not defined $expr;
2325              
2326             # represents the current user's home directory
2327             #
2328             # 7.3. Expanding Tildes in Filenames
2329             # in Chapter 7. File Access
2330             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2331             #
2332             # and File::HomeDir, File::HomeDir::Windows module
2333              
2334             # DOS-like system
2335 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2336 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2337             { my_home_MSWin32() }oxmse;
2338             }
2339              
2340             # UNIX-like system
2341 0 0 0     0 else {
  0         0  
2342             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2343             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2344             }
2345 0 0       0  
2346 0 0       0 # assume global context if not provided one
2347             $cxix = '_G_' if not defined $cxix;
2348             $iter{$cxix} = 0 if not exists $iter{$cxix};
2349 0 0       0  
2350 0         0 # if we're just beginning, do it all first
2351             if ($iter{$cxix} == 0) {
2352             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2353             }
2354 0 0       0  
2355 0         0 # chuck it all out, quick or slow
2356 0         0 if (wantarray) {
  0         0  
2357             delete $iter{$cxix};
2358             return @{delete $entries{$cxix}};
2359 0 0       0 }
  0         0  
2360 0         0 else {
  0         0  
2361             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2362             return shift @{$entries{$cxix}};
2363             }
2364 0         0 else {
2365 0         0 # return undef for EOL
2366 0         0 delete $iter{$cxix};
2367             delete $entries{$cxix};
2368             return undef;
2369             }
2370             }
2371             }
2372              
2373             #
2374             # Latin-2 path globbing subroutine
2375             #
2376 0     0   0 sub _do_glob {
2377 0         0  
2378 0         0 my($cond,@expr) = @_;
2379             my @glob = ();
2380             my $fix_drive_relative_paths = 0;
2381 0         0  
2382 0 0       0 OUTER:
2383 0 0       0 for my $expr (@expr) {
2384             next OUTER if not defined $expr;
2385 0         0 next OUTER if $expr eq '';
2386 0         0  
2387 0         0 my @matched = ();
2388 0         0 my @globdir = ();
2389 0         0 my $head = '.';
2390             my $pathsep = '/';
2391             my $tail;
2392 0 0       0  
2393 0         0 # if argument is within quotes strip em and do no globbing
2394 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2395 0 0       0 $expr = $1;
2396 0         0 if ($cond eq 'd') {
2397             if (-d $expr) {
2398             push @glob, $expr;
2399             }
2400 0 0       0 }
2401 0         0 else {
2402             if (-e $expr) {
2403             push @glob, $expr;
2404 0         0 }
2405             }
2406             next OUTER;
2407             }
2408              
2409 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2410 0 0       0 # to h:./*.pm to expand correctly
2411 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2412             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2413             $fix_drive_relative_paths = 1;
2414             }
2415 0 0       0 }
2416 0 0       0  
2417 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2418 0         0 if ($tail eq '') {
2419             push @glob, $expr;
2420 0 0       0 next OUTER;
2421 0 0       0 }
2422 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2423 0         0 if (@globdir = _do_glob('d', $head)) {
2424             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2425             next OUTER;
2426 0 0 0     0 }
2427 0         0 }
2428             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2429 0         0 $head .= $pathsep;
2430             }
2431             $expr = $tail;
2432             }
2433 0 0       0  
2434 0 0       0 # If file component has no wildcards, we can avoid opendir
2435 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2436             if ($head eq '.') {
2437 0 0 0     0 $head = '';
2438 0         0 }
2439             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2440 0         0 $head .= $pathsep;
2441 0 0       0 }
2442 0 0       0 $head .= $expr;
2443 0         0 if ($cond eq 'd') {
2444             if (-d $head) {
2445             push @glob, $head;
2446             }
2447 0 0       0 }
2448 0         0 else {
2449             if (-e $head) {
2450             push @glob, $head;
2451 0         0 }
2452             }
2453 0 0       0 next OUTER;
2454 0         0 }
2455 0         0 opendir(*DIR, $head) or next OUTER;
2456             my @leaf = readdir DIR;
2457 0 0       0 closedir DIR;
2458 0         0  
2459             if ($head eq '.') {
2460 0 0 0     0 $head = '';
2461 0         0 }
2462             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2463             $head .= $pathsep;
2464 0         0 }
2465 0         0  
2466 0         0 my $pattern = '';
2467             while ($expr =~ / \G ($q_char) /oxgc) {
2468             my $char = $1;
2469              
2470             # 6.9. Matching Shell Globs as Regular Expressions
2471             # in Chapter 6. Pattern Matching
2472             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2473 0 0       0 # (and so on)
    0          
    0          
2474 0         0  
2475             if ($char eq '*') {
2476             $pattern .= "(?:$your_char)*",
2477 0         0 }
2478             elsif ($char eq '?') {
2479             $pattern .= "(?:$your_char)?", # DOS style
2480             # $pattern .= "(?:$your_char)", # UNIX style
2481 0         0 }
2482             elsif ((my $fc = Elatin2::fc($char)) ne $char) {
2483             $pattern .= $fc;
2484 0         0 }
2485             else {
2486             $pattern .= quotemeta $char;
2487 0     0   0 }
  0         0  
2488             }
2489             my $matchsub = sub { Elatin2::fc($_[0]) =~ /\A $pattern \z/xms };
2490              
2491             # if ($@) {
2492             # print STDERR "$0: $@\n";
2493             # next OUTER;
2494             # }
2495 0         0  
2496 0 0 0     0 INNER:
2497 0         0 for my $leaf (@leaf) {
2498             if ($leaf eq '.' or $leaf eq '..') {
2499 0 0 0     0 next INNER;
2500 0         0 }
2501             if ($cond eq 'd' and not -d "$head$leaf") {
2502             next INNER;
2503 0 0       0 }
2504 0         0  
2505 0         0 if (&$matchsub($leaf)) {
2506             push @matched, "$head$leaf";
2507             next INNER;
2508             }
2509              
2510             # [DOS compatibility special case]
2511 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2512              
2513             if (Elatin2::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2514             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2515 0 0       0 Elatin2::index($pattern,'\\.') != -1 # pattern has a dot.
2516 0         0 ) {
2517 0         0 if (&$matchsub("$leaf.")) {
2518             push @matched, "$head$leaf";
2519             next INNER;
2520             }
2521 0 0       0 }
2522 0         0 }
2523             if (@matched) {
2524             push @glob, @matched;
2525 0 0       0 }
2526 0         0 }
2527 0         0 if ($fix_drive_relative_paths) {
2528             for my $glob (@glob) {
2529             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2530 0         0 }
2531             }
2532             return @glob;
2533             }
2534              
2535             #
2536             # Latin-2 parse line
2537             #
2538 0     0   0 sub _parse_line {
2539              
2540 0         0 my($line) = @_;
2541 0         0  
2542 0         0 $line .= ' ';
2543             my @piece = ();
2544             while ($line =~ /
2545             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2546             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2547 0 0       0 /oxmsg
2548             ) {
2549 0         0 push @piece, defined($1) ? $1 : $2;
2550             }
2551             return @piece;
2552             }
2553              
2554             #
2555             # Latin-2 parse path
2556             #
2557 0     0   0 sub _parse_path {
2558              
2559 0         0 my($path,$pathsep) = @_;
2560 0         0  
2561 0         0 $path .= '/';
2562             my @subpath = ();
2563             while ($path =~ /
2564             ((?: [^\/\\] )+?) [\/\\]
2565 0         0 /oxmsg
2566             ) {
2567             push @subpath, $1;
2568 0         0 }
2569 0         0  
2570 0         0 my $tail = pop @subpath;
2571             my $head = join $pathsep, @subpath;
2572             return $head, $tail;
2573             }
2574              
2575             #
2576             # via File::HomeDir::Windows 1.00
2577             #
2578             sub my_home_MSWin32 {
2579              
2580             # A lot of unix people and unix-derived tools rely on
2581 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2582 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2583             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2584             return $ENV{'HOME'};
2585             }
2586              
2587 0         0 # Do we have a user profile?
2588             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2589             return $ENV{'USERPROFILE'};
2590             }
2591              
2592 0         0 # Some Windows use something like $ENV{'HOME'}
2593             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2594             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2595 0         0 }
2596              
2597             return undef;
2598             }
2599              
2600             #
2601             # via File::HomeDir::Unix 1.00
2602 0     0 0 0 #
2603             sub my_home {
2604 0 0 0     0 my $home;
    0 0        
2605 0         0  
2606             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2607             $home = $ENV{'HOME'};
2608             }
2609              
2610             # This is from the original code, but I'm guessing
2611 0         0 # it means "login directory" and exists on some Unixes.
2612             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2613             $home = $ENV{'LOGDIR'};
2614             }
2615              
2616             ### More-desperate methods
2617              
2618 0         0 # Light desperation on any (Unixish) platform
2619             else {
2620             $home = CORE::eval q{ (getpwuid($<))[7] };
2621             }
2622              
2623 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2624 0         0 # For example, "nobody"-like users might use /nonexistant
2625             if (defined $home and ! -d($home)) {
2626 0         0 $home = undef;
2627             }
2628             return $home;
2629             }
2630              
2631             #
2632             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2633 0     0 0 0 #
2634             sub Elatin2::PREMATCH {
2635             return $`;
2636             }
2637              
2638             #
2639             # ${^MATCH}, $MATCH, $& the string that matched
2640 0     0 0 0 #
2641             sub Elatin2::MATCH {
2642             return $&;
2643             }
2644              
2645             #
2646             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2647 0     0 0 0 #
2648             sub Elatin2::POSTMATCH {
2649             return $';
2650             }
2651              
2652             #
2653             # Latin-2 character to order (with parameter)
2654             #
2655 0 0   0 1 0 sub Latin2::ord(;$) {
2656              
2657 0 0       0 local $_ = shift if @_;
2658 0         0  
2659 0         0 if (/\A ($q_char) /oxms) {
2660 0         0 my @ord = unpack 'C*', $1;
2661 0         0 my $ord = 0;
2662             while (my $o = shift @ord) {
2663 0         0 $ord = $ord * 0x100 + $o;
2664             }
2665             return $ord;
2666 0         0 }
2667             else {
2668             return CORE::ord $_;
2669             }
2670             }
2671              
2672             #
2673             # Latin-2 character to order (without parameter)
2674             #
2675 0 0   0 0 0 sub Latin2::ord_() {
2676 0         0  
2677 0         0 if (/\A ($q_char) /oxms) {
2678 0         0 my @ord = unpack 'C*', $1;
2679 0         0 my $ord = 0;
2680             while (my $o = shift @ord) {
2681 0         0 $ord = $ord * 0x100 + $o;
2682             }
2683             return $ord;
2684 0         0 }
2685             else {
2686             return CORE::ord $_;
2687             }
2688             }
2689              
2690             #
2691             # Latin-2 reverse
2692             #
2693 0 0   0 0 0 sub Latin2::reverse(@) {
2694 0         0  
2695             if (wantarray) {
2696             return CORE::reverse @_;
2697             }
2698             else {
2699              
2700             # One of us once cornered Larry in an elevator and asked him what
2701             # problem he was solving with this, but he looked as far off into
2702             # the distance as he could in an elevator and said, "It seemed like
2703 0         0 # a good idea at the time."
2704              
2705             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2706             }
2707             }
2708              
2709             #
2710             # Latin-2 getc (with parameter, without parameter)
2711             #
2712 0     0 0 0 sub Latin2::getc(;*@) {
2713 0 0       0  
2714 0 0 0     0 my($package) = caller;
2715             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2716 0         0 croak 'Too many arguments for Latin2::getc' if @_ and not wantarray;
  0         0  
2717 0         0  
2718 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2719 0         0 my $getc = '';
2720 0 0       0 for my $length ($length[0] .. $length[-1]) {
2721 0 0       0 $getc .= CORE::getc($fh);
2722 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2723             if ($getc =~ /\A ${Elatin2::dot_s} \z/oxms) {
2724             return wantarray ? ($getc,@_) : $getc;
2725             }
2726 0 0       0 }
2727             }
2728             return wantarray ? ($getc,@_) : $getc;
2729             }
2730              
2731             #
2732             # Latin-2 length by character
2733             #
2734 0 0   0 1 0 sub Latin2::length(;$) {
2735              
2736 0         0 local $_ = shift if @_;
2737 0         0  
2738             local @_ = /\G ($q_char) /oxmsg;
2739             return scalar @_;
2740             }
2741              
2742             #
2743             # Latin-2 substr by character
2744             #
2745             BEGIN {
2746              
2747             # P.232 The lvalue Attribute
2748             # in Chapter 6: Subroutines
2749             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2750              
2751             # P.336 The lvalue Attribute
2752             # in Chapter 7: Subroutines
2753             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2754              
2755             # P.144 8.4 Lvalue subroutines
2756             # in Chapter 8: perlsub: Perl subroutines
2757 204 50 0 204 1 130802 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2758              
2759             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2760             # vv----------------------*******
2761             sub Latin2::substr($$;$$) %s {
2762              
2763             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2764              
2765             # If the substring is beyond either end of the string, substr() returns the undefined
2766             # value and produces a warning. When used as an lvalue, specifying a substring that
2767             # is entirely outside the string raises an exception.
2768             # http://perldoc.perl.org/functions/substr.html
2769              
2770             # A return with no argument returns the scalar value undef in scalar context,
2771             # an empty list () in list context, and (naturally) nothing at all in void
2772             # context.
2773              
2774             my $offset = $_[1];
2775             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2776             return;
2777             }
2778              
2779             # substr($string,$offset,$length,$replacement)
2780             if (@_ == 4) {
2781             my(undef,undef,$length,$replacement) = @_;
2782             my $substr = join '', splice(@char, $offset, $length, $replacement);
2783             $_[0] = join '', @char;
2784              
2785             # return $substr; this doesn't work, don't say "return"
2786             $substr;
2787             }
2788              
2789             # substr($string,$offset,$length)
2790             elsif (@_ == 3) {
2791             my(undef,undef,$length) = @_;
2792             my $octet_offset = 0;
2793             my $octet_length = 0;
2794             if ($offset == 0) {
2795             $octet_offset = 0;
2796             }
2797             elsif ($offset > 0) {
2798             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2799             }
2800             else {
2801             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2802             }
2803             if ($length == 0) {
2804             $octet_length = 0;
2805             }
2806             elsif ($length > 0) {
2807             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2808             }
2809             else {
2810             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2811             }
2812             CORE::substr($_[0], $octet_offset, $octet_length);
2813             }
2814              
2815             # substr($string,$offset)
2816             else {
2817             my $octet_offset = 0;
2818             if ($offset == 0) {
2819             $octet_offset = 0;
2820             }
2821             elsif ($offset > 0) {
2822             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2823             }
2824             else {
2825             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2826             }
2827             CORE::substr($_[0], $octet_offset);
2828             }
2829             }
2830             END
2831             }
2832              
2833             #
2834             # Latin-2 index by character
2835             #
2836 0     0 1 0 sub Latin2::index($$;$) {
2837 0 0       0  
2838 0         0 my $index;
2839             if (@_ == 3) {
2840             $index = Elatin2::index($_[0], $_[1], CORE::length(Latin2::substr($_[0], 0, $_[2])));
2841 0         0 }
2842             else {
2843             $index = Elatin2::index($_[0], $_[1]);
2844 0 0       0 }
2845 0         0  
2846             if ($index == -1) {
2847             return -1;
2848 0         0 }
2849             else {
2850             return Latin2::length(CORE::substr $_[0], 0, $index);
2851             }
2852             }
2853              
2854             #
2855             # Latin-2 rindex by character
2856             #
2857 0     0 1 0 sub Latin2::rindex($$;$) {
2858 0 0       0  
2859 0         0 my $rindex;
2860             if (@_ == 3) {
2861             $rindex = Elatin2::rindex($_[0], $_[1], CORE::length(Latin2::substr($_[0], 0, $_[2])));
2862 0         0 }
2863             else {
2864             $rindex = Elatin2::rindex($_[0], $_[1]);
2865 0 0       0 }
2866 0         0  
2867             if ($rindex == -1) {
2868             return -1;
2869 0         0 }
2870             else {
2871             return Latin2::length(CORE::substr $_[0], 0, $rindex);
2872             }
2873             }
2874              
2875 204     204   1919 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         666  
  204         27862  
2876             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2877             use vars qw($slash); $slash = 'm//';
2878              
2879             # ord() to ord() or Latin2::ord()
2880             my $function_ord = 'ord';
2881              
2882             # ord to ord or Latin2::ord_
2883             my $function_ord_ = 'ord';
2884              
2885             # reverse to reverse or Latin2::reverse
2886             my $function_reverse = 'reverse';
2887              
2888             # getc to getc or Latin2::getc
2889             my $function_getc = 'getc';
2890              
2891             # P.1023 Appendix W.9 Multibyte Anchoring
2892             # of ISBN 1-56592-224-7 CJKV Information Processing
2893              
2894 204     204   1542 my $anchor = '';
  204     0   358  
  204         10597799  
2895              
2896             use vars qw($nest);
2897              
2898             # regexp of nested parens in qqXX
2899              
2900             # P.340 Matching Nested Constructs with Embedded Code
2901             # in Chapter 7: Perl
2902             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2903              
2904             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2905             [^\\()] |
2906             \( (?{$nest++}) |
2907             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2908             \\ [^c] |
2909             \\c[\x40-\x5F] |
2910             [\x00-\xFF]
2911             }xms;
2912              
2913             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2914             [^\\{}] |
2915             \{ (?{$nest++}) |
2916             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2917             \\ [^c] |
2918             \\c[\x40-\x5F] |
2919             [\x00-\xFF]
2920             }xms;
2921              
2922             my $qq_bracket = 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_angle = 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_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2941             (?: ::)? (?:
2942             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2943             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2944             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2945             ))
2946             }xms;
2947              
2948             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2949             (?: ::)? (?:
2950             (?>[0-9]+) |
2951             [^a-zA-Z_0-9\[\]] |
2952             ^[A-Z] |
2953             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2954             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2955             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2956             ))
2957             }xms;
2958              
2959             my $qq_substr = qr{(?> Char::substr | Latin2::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2960             }xms;
2961              
2962             # regexp of nested parens in qXX
2963             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2964             [^()] |
2965             \( (?{$nest++}) |
2966             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2967             [\x00-\xFF]
2968             }xms;
2969              
2970             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2971             [^\{\}] |
2972             \{ (?{$nest++}) |
2973             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2974             [\x00-\xFF]
2975             }xms;
2976              
2977             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2978             [^\[\]] |
2979             \[ (?{$nest++}) |
2980             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2981             [\x00-\xFF]
2982             }xms;
2983              
2984             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2985             [^<>] |
2986             \< (?{$nest++}) |
2987             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2988             [\x00-\xFF]
2989             }xms;
2990              
2991             my $matched = '';
2992             my $s_matched = '';
2993              
2994             my $tr_variable = ''; # variable of tr///
2995             my $sub_variable = ''; # variable of s///
2996             my $bind_operator = ''; # =~ or !~
2997              
2998             my @heredoc = (); # here document
2999             my @heredoc_delimiter = ();
3000             my $here_script = ''; # here script
3001              
3002             #
3003             # escape Latin-2 script
3004 0 50   204 0 0 #
3005             sub Latin2::escape(;$) {
3006             local($_) = $_[0] if @_;
3007              
3008             # P.359 The Study Function
3009             # in Chapter 7: Perl
3010 204         772 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3011              
3012             study $_; # Yes, I studied study yesterday.
3013              
3014             # while all script
3015              
3016             # 6.14. Matching from Where the Last Pattern Left Off
3017             # in Chapter 6. Pattern Matching
3018             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3019             # (and so on)
3020              
3021             # one member of Tag-team
3022             #
3023             # P.128 Start of match (or end of previous match): \G
3024             # P.130 Advanced Use of \G with Perl
3025             # in Chapter 3: Overview of Regular Expression Features and Flavors
3026             # P.255 Use leading anchors
3027             # P.256 Expose ^ and \G at the front expressions
3028             # in Chapter 6: Crafting an Efficient Expression
3029             # P.315 "Tag-team" matching with /gc
3030             # in Chapter 7: Perl
3031 204         449 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3032 204         358  
3033 204         2675 my $e_script = '';
3034             while (not /\G \z/oxgc) { # member
3035             $e_script .= Latin2::escape_token();
3036 74977         146289 }
3037              
3038             return $e_script;
3039             }
3040              
3041             #
3042             # escape Latin-2 token of script
3043             #
3044             sub Latin2::escape_token {
3045              
3046 204     74977 0 3337 # \n output here document
3047              
3048             my $ignore_modules = join('|', qw(
3049             utf8
3050             bytes
3051             charnames
3052             I18N::Japanese
3053             I18N::Collate
3054             I18N::JExt
3055             File::DosGlob
3056             Wild
3057             Wildcard
3058             Japanese
3059             ));
3060              
3061             # another member of Tag-team
3062             #
3063             # P.315 "Tag-team" matching with /gc
3064             # in Chapter 7: Perl
3065 74977 100 100     106356 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3066 74977         3118786  
3067 12532 100       15779 if (/\G ( \n ) /oxgc) { # another member (and so on)
3068 12532         30452 my $heredoc = '';
3069             if (scalar(@heredoc_delimiter) >= 1) {
3070 174         244 $slash = 'm//';
3071 174         363  
3072             $heredoc = join '', @heredoc;
3073             @heredoc = ();
3074 174         301  
3075 174         584 # skip here document
3076             for my $heredoc_delimiter (@heredoc_delimiter) {
3077 174         1203 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3078             }
3079 174         955 @heredoc_delimiter = ();
3080              
3081 174         384 $here_script = '';
3082             }
3083             return "\n" . $heredoc;
3084             }
3085 12532         53853  
3086             # ignore space, comment
3087             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3088              
3089             # if (, elsif (, unless (, while (, until (, given (, and when (
3090              
3091             # given, when
3092              
3093             # P.225 The given Statement
3094             # in Chapter 15: Smart Matching and given-when
3095             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3096              
3097             # P.133 The given Statement
3098             # in Chapter 4: Statements and Declarations
3099             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3100 18024         73993  
3101 1401         2437 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3102             $slash = 'm//';
3103             return $1;
3104             }
3105              
3106             # scalar variable ($scalar = ...) =~ tr///;
3107             # scalar variable ($scalar = ...) =~ s///;
3108              
3109             # state
3110              
3111             # P.68 Persistent, Private Variables
3112             # in Chapter 4: Subroutines
3113             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3114              
3115             # P.160 Persistent Lexically Scoped Variables: state
3116             # in Chapter 4: Statements and Declarations
3117             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3118              
3119             # (and so on)
3120 1401         4298  
3121             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3122 86 50       198 my $e_string = e_string($1);
    50          
3123 86         2024  
3124 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3125 0         0 $tr_variable = $e_string . e_string($1);
3126 0         0 $bind_operator = $2;
3127             $slash = 'm//';
3128             return '';
3129 0         0 }
3130 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3131 0         0 $sub_variable = $e_string . e_string($1);
3132 0         0 $bind_operator = $2;
3133             $slash = 'm//';
3134             return '';
3135 0         0 }
3136 86         164 else {
3137             $slash = 'div';
3138             return $e_string;
3139             }
3140             }
3141              
3142 86         460 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
3143 4         7 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3144             $slash = 'div';
3145             return q{Elatin2::PREMATCH()};
3146             }
3147              
3148 4         15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
3149 28         56 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3150             $slash = 'div';
3151             return q{Elatin2::MATCH()};
3152             }
3153              
3154 28         85 # $', ${'} --> $', ${'}
3155 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3156             $slash = 'div';
3157             return $1;
3158             }
3159              
3160 1         5 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
3161 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3162             $slash = 'div';
3163             return q{Elatin2::POSTMATCH()};
3164             }
3165              
3166             # scalar variable $scalar =~ tr///;
3167             # scalar variable $scalar =~ s///;
3168             # substr() =~ tr///;
3169 3         11 # substr() =~ s///;
3170             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3171 1671 100       3820 my $scalar = e_string($1);
    100          
3172 1671         6954  
3173 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3174 1         2 $tr_variable = $scalar;
3175 1         3 $bind_operator = $1;
3176             $slash = 'm//';
3177             return '';
3178 1         3 }
3179 61         123 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3180 61         124 $sub_variable = $scalar;
3181 61         106 $bind_operator = $1;
3182             $slash = 'm//';
3183             return '';
3184 61         197 }
3185 1609         2460 else {
3186             $slash = 'div';
3187             return $scalar;
3188             }
3189             }
3190              
3191 1609         4391 # end of statement
3192             elsif (/\G ( [,;] ) /oxgc) {
3193             $slash = 'm//';
3194 5008         8039  
3195             # clear tr/// variable
3196             $tr_variable = '';
3197 5008         5847  
3198             # clear s/// variable
3199 5008         5711 $sub_variable = '';
3200              
3201 5008         5662 $bind_operator = '';
3202              
3203             return $1;
3204             }
3205              
3206 5008         17290 # bareword
3207             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3208             return $1;
3209             }
3210              
3211 0         0 # $0 --> $0
3212 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3213             $slash = 'div';
3214             return $1;
3215 2         18 }
3216 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3217             $slash = 'div';
3218             return $1;
3219             }
3220              
3221 0         0 # $$ --> $$
3222 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3223             $slash = 'div';
3224             return $1;
3225             }
3226              
3227             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3228 1         3 # $1, $2, $3 --> $1, $2, $3 otherwise
3229 4         7 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3230             $slash = 'div';
3231             return e_capture($1);
3232 4         9 }
3233 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3234             $slash = 'div';
3235             return e_capture($1);
3236             }
3237              
3238 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3239 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3240             $slash = 'div';
3241             return e_capture($1.'->'.$2);
3242             }
3243              
3244 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3245 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3246             $slash = 'div';
3247             return e_capture($1.'->'.$2);
3248             }
3249              
3250 0         0 # $$foo
3251 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3252             $slash = 'div';
3253             return e_capture($1);
3254             }
3255              
3256 0         0 # ${ foo }
3257 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3258             $slash = 'div';
3259             return '${' . $1 . '}';
3260             }
3261              
3262 0         0 # ${ ... }
3263 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3264             $slash = 'div';
3265             return e_capture($1);
3266             }
3267              
3268             # variable or function
3269 0         0 # $ @ % & * $ #
3270 42         71 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) {
3271             $slash = 'div';
3272             return $1;
3273             }
3274             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3275 42         184 # $ @ # \ ' " / ? ( ) [ ] < >
3276 62         128 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3277             $slash = 'div';
3278             return $1;
3279             }
3280              
3281 62         222 # while ()
3282             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3283             return $1;
3284             }
3285              
3286             # while () --- glob
3287              
3288             # avoid "Error: Runtime exception" of perl version 5.005_03
3289 0         0  
3290             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3291             return 'while ($_ = Elatin2::glob("' . $1 . '"))';
3292             }
3293              
3294 0         0 # while (glob)
3295             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3296             return 'while ($_ = Elatin2::glob_)';
3297             }
3298              
3299 0         0 # while (glob(WILDCARD))
3300             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3301             return 'while ($_ = Elatin2::glob';
3302             }
3303 0         0  
  248         629  
3304             # doit if, doit unless, doit while, doit until, doit for, doit when
3305             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3306 248         1016  
  19         34  
3307 19         66 # subroutines of package Elatin2
  0         0  
3308 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         19  
3309 13         35 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3310 0         0 elsif (/\G \b Latin2::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         13914  
3311 114         356 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         3  
3312 2         7 elsif (/\G \b Latin2::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin2::escape'; }
  0         0  
3313 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         3  
3314 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::chop'; }
  0         0  
3315 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3316 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3317 0         0 elsif (/\G \b Latin2::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin2::index'; }
  2         5  
3318 2         6 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::index'; }
  0         0  
3319 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3320 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3321 0         0 elsif (/\G \b Latin2::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin2::rindex'; }
  1         3  
3322 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::rindex'; }
  0         0  
3323 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::lc'; }
  1         3  
3324 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::lcfirst'; }
  0         0  
3325 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::uc'; }
  6         10  
3326             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::ucfirst'; }
3327             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::fc'; }
3328 6         16  
  0         0  
3329 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3330 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3331 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3332 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3333 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3334 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3335             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3336 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3337 0         0  
  0         0  
3338 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3339 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3340 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3341 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3342 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3343             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3344             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3345 0         0  
  0         0  
3346 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3347 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3348 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3349             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3350 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         6  
3351 2         7  
  2         4  
3352 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         61  
3353 36         117 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3354 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::chr'; }
  8         15  
3355 8         25 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3356 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3357 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::glob'; }
  0         0  
3358 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::lc_'; }
  0         0  
3359 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::lcfirst_'; }
  0         0  
3360 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::uc_'; }
  0         0  
3361 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::ucfirst_'; }
  0         0  
3362             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::fc_'; }
3363 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3364 0         0  
  0         0  
3365 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3366 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3367 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::chr_'; }
  0         0  
3368 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3369 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3370 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::glob_'; }
  8         24  
3371             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3372             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3373 8         31 # split
3374             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3375 87         185 $slash = 'm//';
3376 87         143  
3377 87         340 my $e = '';
3378             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3379             $e .= $1;
3380             }
3381 85 100       318  
  87 100       6331  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3382             # end of split
3383             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin2::split' . $e; }
3384 2         8  
3385             # split scalar value
3386             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin2::split' . $e . e_string($1); }
3387 1         5  
3388 0         0 # split literal space
3389 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin2::split' . $e . qq {qq$1 $2}; }
3390 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3391 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3392 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3393 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3394 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3395 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin2::split' . $e . qq {q$1 $2}; }
3396 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3397 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3398 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3399 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3400 10         46 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3401             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin2::split' . $e . qq {' '}; }
3402             elsif (/\G " [ ] " /oxgc) { return 'Elatin2::split' . $e . qq {" "}; }
3403              
3404 0 0       0 # split qq//
  0         0  
3405             elsif (/\G \b (qq) \b /oxgc) {
3406 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3407 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3408 0         0 while (not /\G \z/oxgc) {
3409 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3410 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3411 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3412 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3413 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3414             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3415 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3416             }
3417             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3418             }
3419             }
3420              
3421 0 50       0 # split qr//
  12         422  
3422             elsif (/\G \b (qr) \b /oxgc) {
3423 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3424 12 50       85 else {
  12 50       3909  
    50          
    50          
    50          
    50          
    50          
    50          
3425 0         0 while (not /\G \z/oxgc) {
3426 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3427 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3428 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3429 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3430 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3431 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3432             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3433 12         201 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3434             }
3435             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3436             }
3437             }
3438              
3439 0 0       0 # split q//
  0         0  
3440             elsif (/\G \b (q) \b /oxgc) {
3441 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3442 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3443 0         0 while (not /\G \z/oxgc) {
3444 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3445 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3446 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3447 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3448 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3449             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3450 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3451             }
3452             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3453             }
3454             }
3455              
3456 0 50       0 # split m//
  18         509  
3457             elsif (/\G \b (m) \b /oxgc) {
3458 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3459 18 50       78 else {
  18 50       3705  
    50          
    50          
    50          
    50          
    50          
    50          
3460 0         0 while (not /\G \z/oxgc) {
3461 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3462 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3463 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3464 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3465 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3466 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3467             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3468 18         113 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3469             }
3470             die __FILE__, ": Search pattern not terminated\n";
3471             }
3472             }
3473              
3474 0         0 # split ''
3475 0         0 elsif (/\G (\') /oxgc) {
3476 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3477 0         0 while (not /\G \z/oxgc) {
3478 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3479 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3480             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3481 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3482             }
3483             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3484             }
3485              
3486 0         0 # split ""
3487 0         0 elsif (/\G (\") /oxgc) {
3488 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3489 0         0 while (not /\G \z/oxgc) {
3490 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3491 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3492             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3493 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3494             }
3495             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3496             }
3497              
3498 0         0 # split //
3499 44         120 elsif (/\G (\/) /oxgc) {
3500 44 50       156 my $regexp = '';
  381 50       1808  
    100          
    50          
3501 0         0 while (not /\G \z/oxgc) {
3502 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3503 44         214 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3504             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3505 337         671 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3506             }
3507             die __FILE__, ": Search pattern not terminated\n";
3508             }
3509             }
3510              
3511             # tr/// or y///
3512              
3513             # about [cdsrbB]* (/B modifier)
3514             #
3515             # P.559 appendix C
3516             # of ISBN 4-89052-384-7 Programming perl
3517             # (Japanese title is: Perl puroguramingu)
3518 0         0  
3519             elsif (/\G \b ( tr | y ) \b /oxgc) {
3520             my $ope = $1;
3521 3 50       7  
3522 3         50 # $1 $2 $3 $4 $5 $6
3523 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3524             my @tr = ($tr_variable,$2);
3525             return e_tr(@tr,'',$4,$6);
3526 0         0 }
3527 3         7 else {
3528 3 50       11 my $e = '';
  3 50       269  
    50          
    50          
    50          
    50          
3529             while (not /\G \z/oxgc) {
3530 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3531 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3532 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3533 0         0 while (not /\G \z/oxgc) {
3534 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3535 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3536 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3537 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3538             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3539 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3540             }
3541             die __FILE__, ": Transliteration replacement not terminated\n";
3542 0         0 }
3543 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3544 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3545 0         0 while (not /\G \z/oxgc) {
3546 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3547 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3548 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3549 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3550             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3551 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3552             }
3553             die __FILE__, ": Transliteration replacement not terminated\n";
3554 0         0 }
3555 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3556 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3557 0         0 while (not /\G \z/oxgc) {
3558 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3559 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3560 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3561 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3562             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3563 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3564             }
3565             die __FILE__, ": Transliteration replacement not terminated\n";
3566 0         0 }
3567 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3568 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3569 0         0 while (not /\G \z/oxgc) {
3570 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3571 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3572 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3573 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3574             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3575 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3576             }
3577             die __FILE__, ": Transliteration replacement not terminated\n";
3578             }
3579 0         0 # $1 $2 $3 $4 $5 $6
3580 3         16 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3581             my @tr = ($tr_variable,$2);
3582             return e_tr(@tr,'',$4,$6);
3583 3         11 }
3584             }
3585             die __FILE__, ": Transliteration pattern not terminated\n";
3586             }
3587             }
3588              
3589 0         0 # qq//
3590             elsif (/\G \b (qq) \b /oxgc) {
3591             my $ope = $1;
3592 2180 50       5059  
3593 2180         4578 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3594 0         0 if (/\G (\#) /oxgc) { # qq# #
3595 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3596 0         0 while (not /\G \z/oxgc) {
3597 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3598 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3599             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3600 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3601             }
3602             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3603             }
3604 0         0  
3605 2180         3251 else {
3606 2180 50       5018 my $e = '';
  2180 50       8733  
    100          
    50          
    50          
    0          
3607             while (not /\G \z/oxgc) {
3608             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3609              
3610 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3611 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3612 0         0 my $qq_string = '';
3613 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3614 0         0 while (not /\G \z/oxgc) {
3615 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3616             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3617 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3618 0         0 elsif (/\G (\)) /oxgc) {
3619             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3620 0         0 else { $qq_string .= $1; }
3621             }
3622 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3623             }
3624             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3625             }
3626              
3627 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3628 2150         3219 elsif (/\G (\{) /oxgc) { # qq { }
3629 2150         3088 my $qq_string = '';
3630 2150 100       4447 local $nest = 1;
  84006 50       271885  
    100          
    100          
    50          
3631 722         1513 while (not /\G \z/oxgc) {
3632 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1724  
3633             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3634 1153 100       23898 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5135  
3635 2150         6191 elsif (/\G (\}) /oxgc) {
3636             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3637 1153         2738 else { $qq_string .= $1; }
3638             }
3639 78828         166292 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3640             }
3641             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3642             }
3643              
3644 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3645 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3646 0         0 my $qq_string = '';
3647 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3648 0         0 while (not /\G \z/oxgc) {
3649 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3650             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3651 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3652 0         0 elsif (/\G (\]) /oxgc) {
3653             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3654 0         0 else { $qq_string .= $1; }
3655             }
3656 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3657             }
3658             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3659             }
3660              
3661 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3662 30         56 elsif (/\G (\<) /oxgc) { # qq < >
3663 30         52 my $qq_string = '';
3664 30 100       116 local $nest = 1;
  1166 50       4385  
    50          
    100          
    50          
3665 22         62 while (not /\G \z/oxgc) {
3666 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3667             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3668 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         67  
3669 30         78 elsif (/\G (\>) /oxgc) {
3670             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3671 0         0 else { $qq_string .= $1; }
3672             }
3673 1114         2529 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3674             }
3675             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3676             }
3677              
3678 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3679 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3680 0         0 my $delimiter = $1;
3681 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3682 0         0 while (not /\G \z/oxgc) {
3683 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3684 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3685             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3686 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3687             }
3688             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3689 0         0 }
3690             }
3691             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3692             }
3693             }
3694              
3695 0         0 # qr//
3696 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3697 0         0 my $ope = $1;
3698             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3699             return e_qr($ope,$1,$3,$2,$4);
3700 0         0 }
3701 0         0 else {
3702 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3703 0         0 while (not /\G \z/oxgc) {
3704 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3705 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3706 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3707 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3708 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3709 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3710             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3711 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3712             }
3713             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3714             }
3715             }
3716              
3717 0         0 # qw//
3718 16 50       59 elsif (/\G \b (qw) \b /oxgc) {
3719 16         54 my $ope = $1;
3720             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3721             return e_qw($ope,$1,$3,$2);
3722 0         0 }
3723 16         27 else {
3724 16 50       51 my $e = '';
  16 50       115  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3725             while (not /\G \z/oxgc) {
3726 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3727 16         64  
3728             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3729 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3730 0         0  
3731             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3732 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3733 0         0  
3734             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3735 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3736 0         0  
3737             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3738 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3739 0         0  
3740             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3741 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3742             }
3743             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3744             }
3745             }
3746              
3747 0         0 # qx//
3748 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3749 0         0 my $ope = $1;
3750             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3751             return e_qq($ope,$1,$3,$2);
3752 0         0 }
3753 0         0 else {
3754 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3755 0         0 while (not /\G \z/oxgc) {
3756 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3757 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3758 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3759 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3760 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3761             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3762 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3763             }
3764             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3765             }
3766             }
3767              
3768 0         0 # q//
3769             elsif (/\G \b (q) \b /oxgc) {
3770             my $ope = $1;
3771              
3772             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3773              
3774             # avoid "Error: Runtime exception" of perl version 5.005_03
3775 410 50       1114 # (and so on)
3776 410         1002  
3777 0         0 if (/\G (\#) /oxgc) { # q# #
3778 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3779 0         0 while (not /\G \z/oxgc) {
3780 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3781 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3782             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3783 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3784             }
3785             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3786             }
3787 0         0  
3788 410         689 else {
3789 410 50       1250 my $e = '';
  410 50       4545  
    100          
    50          
    100          
    50          
3790             while (not /\G \z/oxgc) {
3791             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3792              
3793 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3794 0         0 elsif (/\G (\() /oxgc) { # q ( )
3795 0         0 my $q_string = '';
3796 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3797 0         0 while (not /\G \z/oxgc) {
3798 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3799 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3800             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3801 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3802 0         0 elsif (/\G (\)) /oxgc) {
3803             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3804 0         0 else { $q_string .= $1; }
3805             }
3806 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3807             }
3808             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3809             }
3810              
3811 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3812 404         780 elsif (/\G (\{) /oxgc) { # q { }
3813 404         769 my $q_string = '';
3814 404 50       13236 local $nest = 1;
  6770 50       24135  
    50          
    100          
    100          
    50          
3815 0         0 while (not /\G \z/oxgc) {
3816 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3817 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         656  
3818             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3819 107 100       192 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         981  
3820 404         1082 elsif (/\G (\}) /oxgc) {
3821             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3822 107         221 else { $q_string .= $1; }
3823             }
3824 6152         12431 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3825             }
3826             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3827             }
3828              
3829 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3830 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3831 0         0 my $q_string = '';
3832 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3833 0         0 while (not /\G \z/oxgc) {
3834 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3835 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3836             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3837 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3838 0         0 elsif (/\G (\]) /oxgc) {
3839             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3840 0         0 else { $q_string .= $1; }
3841             }
3842 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3843             }
3844             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3845             }
3846              
3847 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3848 5         13 elsif (/\G (\<) /oxgc) { # q < >
3849 5         11 my $q_string = '';
3850 5 50       18 local $nest = 1;
  88 50       392  
    50          
    50          
    100          
    50          
3851 0         0 while (not /\G \z/oxgc) {
3852 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3853 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3854             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3855 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         13  
3856 5         16 elsif (/\G (\>) /oxgc) {
3857             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3858 0         0 else { $q_string .= $1; }
3859             }
3860 83         157 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3861             }
3862             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3863             }
3864              
3865 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3866 1         2 elsif (/\G (\S) /oxgc) { # q * *
3867 1         2 my $delimiter = $1;
3868 1 50       3 my $q_string = '';
  14 50       68  
    100          
    50          
3869 0         0 while (not /\G \z/oxgc) {
3870 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3871 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3872             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3873 13         24 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3874             }
3875             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3876 0         0 }
3877             }
3878             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3879             }
3880             }
3881              
3882 0         0 # m//
3883 209 50       523 elsif (/\G \b (m) \b /oxgc) {
3884 209         1514 my $ope = $1;
3885             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3886             return e_qr($ope,$1,$3,$2,$4);
3887 0         0 }
3888 209         335 else {
3889 209 50       609 my $e = '';
  209 50       11492  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3890 0         0 while (not /\G \z/oxgc) {
3891 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3892 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3893 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3894 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3895 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3896 10         30 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3897 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3898             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3899 199         683 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3900             }
3901             die __FILE__, ": Search pattern not terminated\n";
3902             }
3903             }
3904              
3905             # s///
3906              
3907             # about [cegimosxpradlunbB]* (/cg modifier)
3908             #
3909             # P.67 Pattern-Matching Operators
3910             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3911 0         0  
3912             elsif (/\G \b (s) \b /oxgc) {
3913             my $ope = $1;
3914 97 100       264  
3915 97         1873 # $1 $2 $3 $4 $5 $6
3916             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3917             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3918 1         6 }
3919 96         275 else {
3920 96 50       390 my $e = '';
  96 50       14794  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3921             while (not /\G \z/oxgc) {
3922 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3923 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3924 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3925             while (not /\G \z/oxgc) {
3926 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3927 0         0 # $1 $2 $3 $4
3928 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937             }
3938             die __FILE__, ": Substitution replacement not terminated\n";
3939 0         0 }
3940 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3941 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3942             while (not /\G \z/oxgc) {
3943 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3944 0         0 # $1 $2 $3 $4
3945 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954             }
3955             die __FILE__, ": Substitution replacement not terminated\n";
3956 0         0 }
3957 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3958 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3959             while (not /\G \z/oxgc) {
3960 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3961 0         0 # $1 $2 $3 $4
3962 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969             }
3970             die __FILE__, ": Substitution replacement not terminated\n";
3971 0         0 }
3972 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3973 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3974             while (not /\G \z/oxgc) {
3975 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3976 0         0 # $1 $2 $3 $4
3977 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3985 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3986             }
3987             die __FILE__, ": Substitution replacement not terminated\n";
3988             }
3989 0         0 # $1 $2 $3 $4 $5 $6
3990             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3991             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3992             }
3993 21         63 # $1 $2 $3 $4 $5 $6
3994             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3995             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3996             }
3997 0         0 # $1 $2 $3 $4 $5 $6
3998             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3999             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4000             }
4001 0         0 # $1 $2 $3 $4 $5 $6
4002             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4003             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4004 75         367 }
4005             }
4006             die __FILE__, ": Substitution pattern not terminated\n";
4007             }
4008             }
4009 0         0  
4010 0         0 # require ignore module
4011 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4012             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4013             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4014 0         0  
4015 37         311 # use strict; --> use strict; no strict qw(refs);
4016 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4017             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4018             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4019              
4020 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4021 2         23 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4022             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4023             return "use $1; no strict qw(refs);";
4024 0         0 }
4025             else {
4026             return "use $1;";
4027             }
4028 2 0 0     11 }
      0        
4029 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4030             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4031             return "use $1; no strict qw(refs);";
4032 0         0 }
4033             else {
4034             return "use $1;";
4035             }
4036             }
4037 0         0  
4038 2         19 # ignore use module
4039 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4040             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4041             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4042 0         0  
4043 0         0 # ignore no module
4044 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4045             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4046             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4047 0         0  
4048             # use else
4049             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4050 0         0  
4051             # use else
4052             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4053              
4054 2         9 # ''
4055 848         1739 elsif (/\G (?
4056 848 100       2516 my $q_string = '';
  8254 100       25555  
    100          
    50          
4057 4         11 while (not /\G \z/oxgc) {
4058 48         81 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4059 848         2302 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4060             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4061 7354         15555 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4062             }
4063             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4064             }
4065              
4066 0         0 # ""
4067 1824         4669 elsif (/\G (\") /oxgc) {
4068 1824 100       4703 my $qq_string = '';
  35289 100       103252  
    100          
    50          
4069 67         154 while (not /\G \z/oxgc) {
4070 12         25 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4071 1824         4208 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4072             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4073 33386         67863 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4074             }
4075             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4076             }
4077              
4078 0         0 # ``
4079 1         3 elsif (/\G (\`) /oxgc) {
4080 1 50       4 my $qx_string = '';
  19 50       69  
    100          
    50          
4081 0         0 while (not /\G \z/oxgc) {
4082 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4083 1         2 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4084             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4085 18         33 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4086             }
4087             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4088             }
4089              
4090 0         0 # // --- not divide operator (num / num), not defined-or
4091 453         1412 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4092 453 50       1307 my $regexp = '';
  4496 50       15410  
    100          
    50          
4093 0         0 while (not /\G \z/oxgc) {
4094 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4095 453         2101 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4096             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4097 4043         8718 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4098             }
4099             die __FILE__, ": Search pattern not terminated\n";
4100             }
4101              
4102 0         0 # ?? --- not conditional operator (condition ? then : else)
4103 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4104 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4105 0         0 while (not /\G \z/oxgc) {
4106 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4107 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4108             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4109 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4110             }
4111             die __FILE__, ": Search pattern not terminated\n";
4112             }
4113 0         0  
  0         0  
4114             # <<>> (a safer ARGV)
4115             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4116 0         0  
  0         0  
4117             # << (bit shift) --- not here document
4118             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4119              
4120 0         0 # <<~'HEREDOC'
4121 6         14 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4122 6         14 $slash = 'm//';
4123             my $here_quote = $1;
4124             my $delimiter = $2;
4125 6 50       7  
4126 6         14 # get here document
4127 6         36 if ($here_script eq '') {
4128             $here_script = CORE::substr $_, pos $_;
4129 6 50       36 $here_script =~ s/.*?\n//oxm;
4130 6         57 }
4131 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4132 6         8 my $heredoc = $1;
4133 6         55 my $indent = $2;
4134 6         19 $heredoc =~ s{^$indent}{}msg; # no /ox
4135             push @heredoc, $heredoc . qq{\n$delimiter\n};
4136             push @heredoc_delimiter, qq{\\s*$delimiter};
4137 6         13 }
4138             else {
4139 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4140             }
4141             return qq{<<'$delimiter'};
4142             }
4143              
4144             # <<~\HEREDOC
4145              
4146             # P.66 2.6.6. "Here" Documents
4147             # in Chapter 2: Bits and Pieces
4148             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4149              
4150             # P.73 "Here" Documents
4151             # in Chapter 2: Bits and Pieces
4152             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4153 6         23  
4154 3         8 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4155 3         6 $slash = 'm//';
4156             my $here_quote = $1;
4157             my $delimiter = $2;
4158 3 50       7  
4159 3         7 # get here document
4160 3         11 if ($here_script eq '') {
4161             $here_script = CORE::substr $_, pos $_;
4162 3 50       25 $here_script =~ s/.*?\n//oxm;
4163 3         39 }
4164 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4165 3         4 my $heredoc = $1;
4166 3         47 my $indent = $2;
4167 3         13 $heredoc =~ s{^$indent}{}msg; # no /ox
4168             push @heredoc, $heredoc . qq{\n$delimiter\n};
4169             push @heredoc_delimiter, qq{\\s*$delimiter};
4170 3         6 }
4171             else {
4172 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4173             }
4174             return qq{<<\\$delimiter};
4175             }
4176              
4177 3         13 # <<~"HEREDOC"
4178 6         19 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4179 6         17 $slash = 'm//';
4180             my $here_quote = $1;
4181             my $delimiter = $2;
4182 6 50       26  
4183 6         18 # get here document
4184 6         27 if ($here_script eq '') {
4185             $here_script = CORE::substr $_, pos $_;
4186 6 50       38 $here_script =~ s/.*?\n//oxm;
4187 6         571 }
4188 6         19 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4189 6         10 my $heredoc = $1;
4190 6         62 my $indent = $2;
4191 6         22 $heredoc =~ s{^$indent}{}msg; # no /ox
4192             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4193             push @heredoc_delimiter, qq{\\s*$delimiter};
4194 6         20 }
4195             else {
4196 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4197             }
4198             return qq{<<"$delimiter"};
4199             }
4200              
4201 6         29 # <<~HEREDOC
4202 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4203 3         8 $slash = 'm//';
4204             my $here_quote = $1;
4205             my $delimiter = $2;
4206 3 50       8  
4207 3         11 # get here document
4208 3         84 if ($here_script eq '') {
4209             $here_script = CORE::substr $_, pos $_;
4210 3 50       23 $here_script =~ s/.*?\n//oxm;
4211 3         52 }
4212 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4213 3         78 my $heredoc = $1;
4214 3         54 my $indent = $2;
4215 3         14 $heredoc =~ s{^$indent}{}msg; # no /ox
4216             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4217             push @heredoc_delimiter, qq{\\s*$delimiter};
4218 3         9 }
4219             else {
4220 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4221             }
4222             return qq{<<$delimiter};
4223             }
4224              
4225 3         17 # <<~`HEREDOC`
4226 6         16 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4227 6         14 $slash = 'm//';
4228             my $here_quote = $1;
4229             my $delimiter = $2;
4230 6 50       13  
4231 6         692 # get here document
4232 6         24 if ($here_script eq '') {
4233             $here_script = CORE::substr $_, pos $_;
4234 6 50       32 $here_script =~ s/.*?\n//oxm;
4235 6         78 }
4236 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4237 6         10 my $heredoc = $1;
4238 6         56 my $indent = $2;
4239 6         64 $heredoc =~ s{^$indent}{}msg; # no /ox
4240             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4241             push @heredoc_delimiter, qq{\\s*$delimiter};
4242 6         16 }
4243             else {
4244 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4245             }
4246             return qq{<<`$delimiter`};
4247             }
4248              
4249 6         36 # <<'HEREDOC'
4250 72         150 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4251 72         234 $slash = 'm//';
4252             my $here_quote = $1;
4253             my $delimiter = $2;
4254 72 50       127  
4255 72         183 # get here document
4256 72         596 if ($here_script eq '') {
4257             $here_script = CORE::substr $_, pos $_;
4258 72 50       931 $here_script =~ s/.*?\n//oxm;
4259 72         671 }
4260 72         254 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4261             push @heredoc, $1 . qq{\n$delimiter\n};
4262             push @heredoc_delimiter, $delimiter;
4263 72         201 }
4264             else {
4265 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4266             }
4267             return $here_quote;
4268             }
4269              
4270             # <<\HEREDOC
4271              
4272             # P.66 2.6.6. "Here" Documents
4273             # in Chapter 2: Bits and Pieces
4274             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4275              
4276             # P.73 "Here" Documents
4277             # in Chapter 2: Bits and Pieces
4278             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4279 72         278  
4280 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4281 0         0 $slash = 'm//';
4282             my $here_quote = $1;
4283             my $delimiter = $2;
4284 0 0       0  
4285 0         0 # get here document
4286 0         0 if ($here_script eq '') {
4287             $here_script = CORE::substr $_, pos $_;
4288 0 0       0 $here_script =~ s/.*?\n//oxm;
4289 0         0 }
4290 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4291             push @heredoc, $1 . qq{\n$delimiter\n};
4292             push @heredoc_delimiter, $delimiter;
4293 0         0 }
4294             else {
4295 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4296             }
4297             return $here_quote;
4298             }
4299              
4300 0         0 # <<"HEREDOC"
4301 36         87 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4302 36         81 $slash = 'm//';
4303             my $here_quote = $1;
4304             my $delimiter = $2;
4305 36 50       67  
4306 36         111 # get here document
4307 36         543 if ($here_script eq '') {
4308             $here_script = CORE::substr $_, pos $_;
4309 36 50       216 $here_script =~ s/.*?\n//oxm;
4310 36         497 }
4311 36         123 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4312             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4313             push @heredoc_delimiter, $delimiter;
4314 36         89 }
4315             else {
4316 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4317             }
4318             return $here_quote;
4319             }
4320              
4321 36         143 # <
4322 42         100 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4323 42         92 $slash = 'm//';
4324             my $here_quote = $1;
4325             my $delimiter = $2;
4326 42 50       87  
4327 42         110 # get here document
4328 42         310 if ($here_script eq '') {
4329             $here_script = CORE::substr $_, pos $_;
4330 42 50       307 $here_script =~ s/.*?\n//oxm;
4331 42         661 }
4332 42         146 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4333             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4334             push @heredoc_delimiter, $delimiter;
4335 42         94 }
4336             else {
4337 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4338             }
4339             return $here_quote;
4340             }
4341              
4342 42         167 # <<`HEREDOC`
4343 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4344 0         0 $slash = 'm//';
4345             my $here_quote = $1;
4346             my $delimiter = $2;
4347 0 0       0  
4348 0         0 # get here document
4349 0         0 if ($here_script eq '') {
4350             $here_script = CORE::substr $_, pos $_;
4351 0 0       0 $here_script =~ s/.*?\n//oxm;
4352 0         0 }
4353 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4354             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4355             push @heredoc_delimiter, $delimiter;
4356 0         0 }
4357             else {
4358 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4359             }
4360             return $here_quote;
4361             }
4362              
4363 0         0 # <<= <=> <= < operator
4364             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4365             return $1;
4366             }
4367              
4368 12         69 #
4369             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4370             return $1;
4371             }
4372              
4373             # --- glob
4374              
4375             # avoid "Error: Runtime exception" of perl version 5.005_03
4376 0         0  
4377             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4378             return 'Elatin2::glob("' . $1 . '")';
4379             }
4380 0         0  
4381             # __DATA__
4382             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4383 0         0  
4384             # __END__
4385             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4386              
4387             # \cD Control-D
4388              
4389             # P.68 2.6.8. Other Literal Tokens
4390             # in Chapter 2: Bits and Pieces
4391             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4392              
4393             # P.76 Other Literal Tokens
4394             # in Chapter 2: Bits and Pieces
4395 204         2352 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4396              
4397             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4398 0         0  
4399             # \cZ Control-Z
4400             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4401              
4402             # any operator before div
4403             elsif (/\G (
4404             -- | \+\+ |
4405 0         0 [\)\}\]]
  5081         11281  
4406              
4407             ) /oxgc) { $slash = 'div'; return $1; }
4408              
4409             # yada-yada or triple-dot operator
4410             elsif (/\G (
4411 5081         23724 \.\.\.
  7         14  
4412              
4413             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4414              
4415             # any operator before m//
4416              
4417             # //, //= (defined-or)
4418              
4419             # P.164 Logical Operators
4420             # in Chapter 10: More Control Structures
4421             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4422              
4423             # P.119 C-Style Logical (Short-Circuit) Operators
4424             # in Chapter 3: Unary and Binary Operators
4425             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4426              
4427             # (and so on)
4428              
4429             # ~~
4430              
4431             # P.221 The Smart Match Operator
4432             # in Chapter 15: Smart Matching and given-when
4433             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4434              
4435             # P.112 Smartmatch Operator
4436             # in Chapter 3: Unary and Binary Operators
4437             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4438              
4439             # (and so on)
4440              
4441             elsif (/\G ((?>
4442              
4443             !~~ | !~ | != | ! |
4444             %= | % |
4445             &&= | && | &= | &\.= | &\. | & |
4446             -= | -> | - |
4447             :(?>\s*)= |
4448             : |
4449             <<>> |
4450             <<= | <=> | <= | < |
4451             == | => | =~ | = |
4452             >>= | >> | >= | > |
4453             \*\*= | \*\* | \*= | \* |
4454             \+= | \+ |
4455             \.\. | \.= | \. |
4456             \/\/= | \/\/ |
4457             \/= | \/ |
4458             \? |
4459             \\ |
4460             \^= | \^\.= | \^\. | \^ |
4461             \b x= |
4462             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4463             ~~ | ~\. | ~ |
4464             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4465             \b(?: print )\b |
4466              
4467 7         24 [,;\(\{\[]
  8856         18540  
4468              
4469             )) /oxgc) { $slash = 'm//'; return $1; }
4470 8856         41017  
  15137         29610  
4471             # other any character
4472             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4473              
4474 15137         70545 # system error
4475             else {
4476             die __FILE__, ": Oops, this shouldn't happen!\n";
4477             }
4478             }
4479              
4480 0     1786 0 0 # escape Latin-2 string
4481 1786         4118 sub e_string {
4482             my($string) = @_;
4483 1786         2859 my $e_string = '';
4484              
4485             local $slash = 'm//';
4486              
4487             # P.1024 Appendix W.10 Multibyte Processing
4488             # of ISBN 1-56592-224-7 CJKV Information Processing
4489 1786         2719 # (and so on)
4490              
4491             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4492 1786 100 66     13757  
4493 1786 50       7982 # without { ... }
4494 1769         4172 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4495             if ($string !~ /<
4496             return $string;
4497             }
4498             }
4499 1769         5422  
4500 17 50       62 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4501             while ($string !~ /\G \z/oxgc) {
4502             if (0) {
4503             }
4504 190         12278  
4505 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin2::PREMATCH()]}
4506 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4507             $e_string .= q{Elatin2::PREMATCH()};
4508             $slash = 'div';
4509             }
4510              
4511 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin2::MATCH()]}
4512 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4513             $e_string .= q{Elatin2::MATCH()};
4514             $slash = 'div';
4515             }
4516              
4517 0         0 # $', ${'} --> $', ${'}
4518 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4519             $e_string .= $1;
4520             $slash = 'div';
4521             }
4522              
4523 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin2::POSTMATCH()]}
4524 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4525             $e_string .= q{Elatin2::POSTMATCH()};
4526             $slash = 'div';
4527             }
4528              
4529 0         0 # bareword
4530 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4531             $e_string .= $1;
4532             $slash = 'div';
4533             }
4534              
4535 0         0 # $0 --> $0
4536 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4537             $e_string .= $1;
4538             $slash = 'div';
4539 0         0 }
4540 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4541             $e_string .= $1;
4542             $slash = 'div';
4543             }
4544              
4545 0         0 # $$ --> $$
4546 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4547             $e_string .= $1;
4548             $slash = 'div';
4549             }
4550              
4551             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4552 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4553 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4554             $e_string .= e_capture($1);
4555             $slash = 'div';
4556 0         0 }
4557 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4558             $e_string .= e_capture($1);
4559             $slash = 'div';
4560             }
4561              
4562 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4563 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4564             $e_string .= e_capture($1.'->'.$2);
4565             $slash = 'div';
4566             }
4567              
4568 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4569 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4570             $e_string .= e_capture($1.'->'.$2);
4571             $slash = 'div';
4572             }
4573              
4574 0         0 # $$foo
4575 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4576             $e_string .= e_capture($1);
4577             $slash = 'div';
4578             }
4579              
4580 0         0 # ${ foo }
4581 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4582             $e_string .= '${' . $1 . '}';
4583             $slash = 'div';
4584             }
4585              
4586 0         0 # ${ ... }
4587 3         8 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4588             $e_string .= e_capture($1);
4589             $slash = 'div';
4590             }
4591              
4592             # variable or function
4593 3         14 # $ @ % & * $ #
4594 7         20 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) {
4595             $e_string .= $1;
4596             $slash = 'div';
4597             }
4598             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4599 7         23 # $ @ # \ ' " / ? ( ) [ ] < >
4600 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4601             $e_string .= $1;
4602             $slash = 'div';
4603             }
4604 0         0  
  0         0  
4605 0         0 # subroutines of package Elatin2
  0         0  
4606 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4607 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4608 0         0 elsif ($string =~ /\G \b Latin2::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4609 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4610 0         0 elsif ($string =~ /\G \b Latin2::eval \b /oxgc) { $e_string .= 'eval Latin2::escape'; $slash = 'm//'; }
  0         0  
4611 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4612 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin2::chop'; $slash = 'm//'; }
  0         0  
4613 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4614 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4615 0         0 elsif ($string =~ /\G \b Latin2::index \b /oxgc) { $e_string .= 'Latin2::index'; $slash = 'm//'; }
  0         0  
4616 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin2::index'; $slash = 'm//'; }
  0         0  
4617 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4618 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4619 0         0 elsif ($string =~ /\G \b Latin2::rindex \b /oxgc) { $e_string .= 'Latin2::rindex'; $slash = 'm//'; }
  0         0  
4620 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin2::rindex'; $slash = 'm//'; }
  0         0  
4621 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::lc'; $slash = 'm//'; }
  0         0  
4622 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::lcfirst'; $slash = 'm//'; }
  0         0  
4623 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::uc'; $slash = 'm//'; }
  0         0  
4624             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::ucfirst'; $slash = 'm//'; }
4625             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::fc'; $slash = 'm//'; }
4626 0         0  
  0         0  
4627 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4628 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4629 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4630 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4631 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4632 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4633             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4634 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4635 0         0  
  0         0  
4636 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4637 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4638 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4639 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4641             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4642             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4643 0         0  
  0         0  
4644 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4645 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4646 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4647             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4648 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4649 0         0  
  0         0  
4650 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4651 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4652 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::chr'; $slash = 'm//'; }
  0         0  
4653 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4654 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4655 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::glob'; $slash = 'm//'; }
  0         0  
4656 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin2::lc_'; $slash = 'm//'; }
  0         0  
4657 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin2::lcfirst_'; $slash = 'm//'; }
  0         0  
4658 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin2::uc_'; $slash = 'm//'; }
  0         0  
4659 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin2::ucfirst_'; $slash = 'm//'; }
  0         0  
4660             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin2::fc_'; $slash = 'm//'; }
4661 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4662 0         0  
  0         0  
4663 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4664 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4665 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin2::chr_'; $slash = 'm//'; }
  0         0  
4666 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4667 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4668 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin2::glob_'; $slash = 'm//'; }
  0         0  
4669             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4670             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4671 0         0 # split
4672             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4673 0         0 $slash = 'm//';
4674 0         0  
4675 0         0 my $e = '';
4676             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4677             $e .= $1;
4678             }
4679 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4680             # end of split
4681             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin2::split' . $e; }
4682 0         0  
  0         0  
4683             # split scalar value
4684             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin2::split' . $e . e_string($1); next E_STRING_LOOP; }
4685 0         0  
  0         0  
4686 0         0 # split literal space
  0         0  
4687 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4688 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4689 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4690 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4691 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4692 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4693 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4694 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4695 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4696 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4697 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4698 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4699             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {' '}; next E_STRING_LOOP; }
4700             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {" "}; next E_STRING_LOOP; }
4701              
4702 0 0       0 # split qq//
  0         0  
  0         0  
4703             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4704 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4705 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4706 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4707 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4708 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4709 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4710 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4711 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4712             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4713 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
4714             }
4715             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4716             }
4717             }
4718              
4719 0 0       0 # split qr//
  0         0  
  0         0  
4720             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4721 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4722 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4723 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4724 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4725 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4726 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4727 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4728 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4729 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4730             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4731 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
4732             }
4733             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4734             }
4735             }
4736              
4737 0 0       0 # split q//
  0         0  
  0         0  
4738             elsif ($string =~ /\G \b (q) \b /oxgc) {
4739 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4740 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4741 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4742 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4743 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4744 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4745 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4746 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4747             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4748 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
4749             }
4750             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4751             }
4752             }
4753              
4754 0 0       0 # split m//
  0         0  
  0         0  
4755             elsif ($string =~ /\G \b (m) \b /oxgc) {
4756 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 # #
4757 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4758 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4759 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4760 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4761 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4762 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4763 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4764 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4765             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4766 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
4767             }
4768             die __FILE__, ": Search pattern not terminated\n";
4769             }
4770             }
4771              
4772 0         0 # split ''
4773 0         0 elsif ($string =~ /\G (\') /oxgc) {
4774 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4775 0         0 while ($string !~ /\G \z/oxgc) {
4776 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4777 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4778             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4779 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4780             }
4781             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4782             }
4783              
4784 0         0 # split ""
4785 0         0 elsif ($string =~ /\G (\") /oxgc) {
4786 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4787 0         0 while ($string !~ /\G \z/oxgc) {
4788 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4789 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4790             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4791 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4792             }
4793             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4794             }
4795              
4796 0         0 # split //
4797 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4798 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4799 0         0 while ($string !~ /\G \z/oxgc) {
4800 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4801 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4802             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4803 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4804             }
4805             die __FILE__, ": Search pattern not terminated\n";
4806             }
4807             }
4808              
4809 0         0 # qq//
4810 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4811 0         0 my $ope = $1;
4812             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4813             $e_string .= e_qq($ope,$1,$3,$2);
4814 0         0 }
4815 0         0 else {
4816 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4817 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4818 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4819 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4820 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4821 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4822             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4823 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4824             }
4825             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4826             }
4827             }
4828              
4829 0         0 # qx//
4830 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4831 0         0 my $ope = $1;
4832             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4833             $e_string .= e_qq($ope,$1,$3,$2);
4834 0         0 }
4835 0         0 else {
4836 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4837 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4838 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4839 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4840 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4841 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4842 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4843             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4844 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4845             }
4846             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4847             }
4848             }
4849              
4850 0         0 # q//
4851 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4852 0         0 my $ope = $1;
4853             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4854             $e_string .= e_q($ope,$1,$3,$2);
4855 0         0 }
4856 0         0 else {
4857 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4858 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4859 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4860 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4861 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4862 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4863             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4864 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
4865             }
4866             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4867             }
4868             }
4869 0         0  
4870             # ''
4871             elsif ($string =~ /\G (?
4872 0         0  
4873             # ""
4874             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4875 0         0  
4876             # ``
4877             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4878 0         0  
4879             # <<>> (a safer ARGV)
4880             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4881 0         0  
4882             # <<= <=> <= < operator
4883             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4884 0         0  
4885             #
4886             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4887              
4888 0         0 # --- glob
4889             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4890             $e_string .= 'Elatin2::glob("' . $1 . '")';
4891             }
4892              
4893 0         0 # << (bit shift) --- not here document
4894 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4895             $slash = 'm//';
4896             $e_string .= $1;
4897             }
4898              
4899 0         0 # <<~'HEREDOC'
4900 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4901 0         0 $slash = 'm//';
4902             my $here_quote = $1;
4903             my $delimiter = $2;
4904 0 0       0  
4905 0         0 # get here document
4906 0         0 if ($here_script eq '') {
4907             $here_script = CORE::substr $_, pos $_;
4908 0 0       0 $here_script =~ s/.*?\n//oxm;
4909 0         0 }
4910 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4911 0         0 my $heredoc = $1;
4912 0         0 my $indent = $2;
4913 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4914             push @heredoc, $heredoc . qq{\n$delimiter\n};
4915             push @heredoc_delimiter, qq{\\s*$delimiter};
4916 0         0 }
4917             else {
4918 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4919             }
4920             $e_string .= qq{<<'$delimiter'};
4921             }
4922              
4923 0         0 # <<~\HEREDOC
4924 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4925 0         0 $slash = 'm//';
4926             my $here_quote = $1;
4927             my $delimiter = $2;
4928 0 0       0  
4929 0         0 # get here document
4930 0         0 if ($here_script eq '') {
4931             $here_script = CORE::substr $_, pos $_;
4932 0 0       0 $here_script =~ s/.*?\n//oxm;
4933 0         0 }
4934 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4935 0         0 my $heredoc = $1;
4936 0         0 my $indent = $2;
4937 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4938             push @heredoc, $heredoc . qq{\n$delimiter\n};
4939             push @heredoc_delimiter, qq{\\s*$delimiter};
4940 0         0 }
4941             else {
4942 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4943             }
4944             $e_string .= qq{<<\\$delimiter};
4945             }
4946              
4947 0         0 # <<~"HEREDOC"
4948 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4949 0         0 $slash = 'm//';
4950             my $here_quote = $1;
4951             my $delimiter = $2;
4952 0 0       0  
4953 0         0 # get here document
4954 0         0 if ($here_script eq '') {
4955             $here_script = CORE::substr $_, pos $_;
4956 0 0       0 $here_script =~ s/.*?\n//oxm;
4957 0         0 }
4958 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4959 0         0 my $heredoc = $1;
4960 0         0 my $indent = $2;
4961 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4962             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4963             push @heredoc_delimiter, qq{\\s*$delimiter};
4964 0         0 }
4965             else {
4966 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4967             }
4968             $e_string .= qq{<<"$delimiter"};
4969             }
4970              
4971 0         0 # <<~HEREDOC
4972 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4973 0         0 $slash = 'm//';
4974             my $here_quote = $1;
4975             my $delimiter = $2;
4976 0 0       0  
4977 0         0 # get here document
4978 0         0 if ($here_script eq '') {
4979             $here_script = CORE::substr $_, pos $_;
4980 0 0       0 $here_script =~ s/.*?\n//oxm;
4981 0         0 }
4982 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4983 0         0 my $heredoc = $1;
4984 0         0 my $indent = $2;
4985 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4986             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4987             push @heredoc_delimiter, qq{\\s*$delimiter};
4988 0         0 }
4989             else {
4990 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4991             }
4992             $e_string .= qq{<<$delimiter};
4993             }
4994              
4995 0         0 # <<~`HEREDOC`
4996 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4997 0         0 $slash = 'm//';
4998             my $here_quote = $1;
4999             my $delimiter = $2;
5000 0 0       0  
5001 0         0 # get here document
5002 0         0 if ($here_script eq '') {
5003             $here_script = CORE::substr $_, pos $_;
5004 0 0       0 $here_script =~ s/.*?\n//oxm;
5005 0         0 }
5006 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5007 0         0 my $heredoc = $1;
5008 0         0 my $indent = $2;
5009 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5010             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5011             push @heredoc_delimiter, qq{\\s*$delimiter};
5012 0         0 }
5013             else {
5014 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5015             }
5016             $e_string .= qq{<<`$delimiter`};
5017             }
5018              
5019 0         0 # <<'HEREDOC'
5020 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5021 0         0 $slash = 'm//';
5022             my $here_quote = $1;
5023             my $delimiter = $2;
5024 0 0       0  
5025 0         0 # get here document
5026 0         0 if ($here_script eq '') {
5027             $here_script = CORE::substr $_, pos $_;
5028 0 0       0 $here_script =~ s/.*?\n//oxm;
5029 0         0 }
5030 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5031             push @heredoc, $1 . qq{\n$delimiter\n};
5032             push @heredoc_delimiter, $delimiter;
5033 0         0 }
5034             else {
5035 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5036             }
5037             $e_string .= $here_quote;
5038             }
5039              
5040 0         0 # <<\HEREDOC
5041 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5042 0         0 $slash = 'm//';
5043             my $here_quote = $1;
5044             my $delimiter = $2;
5045 0 0       0  
5046 0         0 # get here document
5047 0         0 if ($here_script eq '') {
5048             $here_script = CORE::substr $_, pos $_;
5049 0 0       0 $here_script =~ s/.*?\n//oxm;
5050 0         0 }
5051 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5052             push @heredoc, $1 . qq{\n$delimiter\n};
5053             push @heredoc_delimiter, $delimiter;
5054 0         0 }
5055             else {
5056 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5057             }
5058             $e_string .= $here_quote;
5059             }
5060              
5061 0         0 # <<"HEREDOC"
5062 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5063 0         0 $slash = 'm//';
5064             my $here_quote = $1;
5065             my $delimiter = $2;
5066 0 0       0  
5067 0         0 # get here document
5068 0         0 if ($here_script eq '') {
5069             $here_script = CORE::substr $_, pos $_;
5070 0 0       0 $here_script =~ s/.*?\n//oxm;
5071 0         0 }
5072 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5073             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5074             push @heredoc_delimiter, $delimiter;
5075 0         0 }
5076             else {
5077 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5078             }
5079             $e_string .= $here_quote;
5080             }
5081              
5082 0         0 # <
5083 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5084 0         0 $slash = 'm//';
5085             my $here_quote = $1;
5086             my $delimiter = $2;
5087 0 0       0  
5088 0         0 # get here document
5089 0         0 if ($here_script eq '') {
5090             $here_script = CORE::substr $_, pos $_;
5091 0 0       0 $here_script =~ s/.*?\n//oxm;
5092 0         0 }
5093 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5094             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5095             push @heredoc_delimiter, $delimiter;
5096 0         0 }
5097             else {
5098 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5099             }
5100             $e_string .= $here_quote;
5101             }
5102              
5103 0         0 # <<`HEREDOC`
5104 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5105 0         0 $slash = 'm//';
5106             my $here_quote = $1;
5107             my $delimiter = $2;
5108 0 0       0  
5109 0         0 # get here document
5110 0         0 if ($here_script eq '') {
5111             $here_script = CORE::substr $_, pos $_;
5112 0 0       0 $here_script =~ s/.*?\n//oxm;
5113 0         0 }
5114 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5115             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5116             push @heredoc_delimiter, $delimiter;
5117 0         0 }
5118             else {
5119 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5120             }
5121             $e_string .= $here_quote;
5122             }
5123              
5124             # any operator before div
5125             elsif ($string =~ /\G (
5126             -- | \+\+ |
5127 0         0 [\)\}\]]
  18         33  
5128              
5129             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5130              
5131             # yada-yada or triple-dot operator
5132             elsif ($string =~ /\G (
5133 18         53 \.\.\.
  0         0  
5134              
5135             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5136              
5137             # any operator before m//
5138             elsif ($string =~ /\G ((?>
5139              
5140             !~~ | !~ | != | ! |
5141             %= | % |
5142             &&= | && | &= | &\.= | &\. | & |
5143             -= | -> | - |
5144             :(?>\s*)= |
5145             : |
5146             <<>> |
5147             <<= | <=> | <= | < |
5148             == | => | =~ | = |
5149             >>= | >> | >= | > |
5150             \*\*= | \*\* | \*= | \* |
5151             \+= | \+ |
5152             \.\. | \.= | \. |
5153             \/\/= | \/\/ |
5154             \/= | \/ |
5155             \? |
5156             \\ |
5157             \^= | \^\.= | \^\. | \^ |
5158             \b x= |
5159             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5160             ~~ | ~\. | ~ |
5161             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5162             \b(?: print )\b |
5163              
5164 0         0 [,;\(\{\[]
  31         59  
5165              
5166             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5167 31         156  
5168             # other any character
5169             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5170              
5171 131         352 # system error
5172             else {
5173             die __FILE__, ": Oops, this shouldn't happen!\n";
5174             }
5175 0         0 }
5176              
5177             return $e_string;
5178             }
5179              
5180             #
5181             # character class
5182 17     1919 0 83 #
5183             sub character_class {
5184 1919 100       3638 my($char,$modifier) = @_;
5185 1919 100       3268  
5186 52         91 if ($char eq '.') {
5187             if ($modifier =~ /s/) {
5188             return '${Elatin2::dot_s}';
5189 17         37 }
5190             else {
5191             return '${Elatin2::dot}';
5192             }
5193 35         74 }
5194             else {
5195             return Elatin2::classic_character_class($char);
5196             }
5197             }
5198              
5199             #
5200             # escape capture ($1, $2, $3, ...)
5201             #
5202 1867     212 0 3363 sub e_capture {
5203              
5204             return join '', '${', $_[0], '}';
5205             }
5206              
5207             #
5208             # escape transliteration (tr/// or y///)
5209 212     3 0 887 #
5210 3         23 sub e_tr {
5211 3   50     7 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5212             my $e_tr = '';
5213 3         8 $modifier ||= '';
5214              
5215             $slash = 'div';
5216 3         6  
5217             # quote character class 1
5218             $charclass = q_tr($charclass);
5219 3         9  
5220             # quote character class 2
5221             $charclass2 = q_tr($charclass2);
5222 3 50       6  
5223 3 0       10 # /b /B modifier
5224 0         0 if ($modifier =~ tr/bB//d) {
5225             if ($variable eq '') {
5226             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5227 0         0 }
5228             else {
5229             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5230             }
5231 0 100       0 }
5232 3         37 else {
5233             if ($variable eq '') {
5234             $e_tr = qq{Elatin2::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5235 2         9 }
5236             else {
5237             $e_tr = qq{Elatin2::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5238             }
5239             }
5240 1         6  
5241 3         6 # clear tr/// variable
5242             $tr_variable = '';
5243 3         4 $bind_operator = '';
5244              
5245             return $e_tr;
5246             }
5247              
5248             #
5249             # quote for escape transliteration (tr/// or y///)
5250 3     6 0 20 #
5251             sub q_tr {
5252             my($charclass) = @_;
5253 6 50       11  
    0          
    0          
    0          
    0          
    0          
5254 6         13 # quote character class
5255             if ($charclass !~ /'/oxms) {
5256             return e_q('', "'", "'", $charclass); # --> q' '
5257 6         13 }
5258             elsif ($charclass !~ /\//oxms) {
5259             return e_q('q', '/', '/', $charclass); # --> q/ /
5260 0         0 }
5261             elsif ($charclass !~ /\#/oxms) {
5262             return e_q('q', '#', '#', $charclass); # --> q# #
5263 0         0 }
5264             elsif ($charclass !~ /[\<\>]/oxms) {
5265             return e_q('q', '<', '>', $charclass); # --> q< >
5266 0         0 }
5267             elsif ($charclass !~ /[\(\)]/oxms) {
5268             return e_q('q', '(', ')', $charclass); # --> q( )
5269 0         0 }
5270             elsif ($charclass !~ /[\{\}]/oxms) {
5271             return e_q('q', '{', '}', $charclass); # --> q{ }
5272 0         0 }
5273 0 0       0 else {
5274 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5275             if ($charclass !~ /\Q$char\E/xms) {
5276             return e_q('q', $char, $char, $charclass);
5277             }
5278             }
5279 0         0 }
5280              
5281             return e_q('q', '{', '}', $charclass);
5282             }
5283              
5284             #
5285             # escape q string (q//, '')
5286 0     1264 0 0 #
5287             sub e_q {
5288 1264         2982 my($ope,$delimiter,$end_delimiter,$string) = @_;
5289              
5290 1264         1924 $slash = 'div';
5291              
5292             return join '', $ope, $delimiter, $string, $end_delimiter;
5293             }
5294              
5295             #
5296             # escape qq string (qq//, "", qx//, ``)
5297 1264     4086 0 6747 #
5298             sub e_qq {
5299 4086         10147 my($ope,$delimiter,$end_delimiter,$string) = @_;
5300              
5301 4086         6908 $slash = 'div';
5302 4086         5023  
5303             my $left_e = 0;
5304             my $right_e = 0;
5305 4086         4774  
5306             # split regexp
5307             my @char = $string =~ /\G((?>
5308             [^\\\$] |
5309             \\x\{ (?>[0-9A-Fa-f]+) \} |
5310             \\o\{ (?>[0-7]+) \} |
5311             \\N\{ (?>[^0-9\}][^\}]*) \} |
5312             \\ $q_char |
5313             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5314             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5315             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5316             \$ (?>\s* [0-9]+) |
5317             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5318             \$ \$ (?![\w\{]) |
5319             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5320             $q_char
5321 4086         146598 ))/oxmsg;
5322              
5323             for (my $i=0; $i <= $#char; $i++) {
5324 4086 50 33     12964  
    50 33        
    100          
    100          
    50          
5325 113901         397897 # "\L\u" --> "\u\L"
5326             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5327             @char[$i,$i+1] = @char[$i+1,$i];
5328             }
5329              
5330 0         0 # "\U\l" --> "\l\U"
5331             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5332             @char[$i,$i+1] = @char[$i+1,$i];
5333             }
5334              
5335 0         0 # octal escape sequence
5336             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5337             $char[$i] = Elatin2::octchr($1);
5338             }
5339              
5340 1         5 # hexadecimal escape sequence
5341             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5342             $char[$i] = Elatin2::hexchr($1);
5343             }
5344              
5345 1         5 # \N{CHARNAME} --> N{CHARNAME}
5346             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5347             $char[$i] = $1;
5348 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5349              
5350             if (0) {
5351             }
5352              
5353             # \F
5354             #
5355             # P.69 Table 2-6. Translation escapes
5356             # in Chapter 2: Bits and Pieces
5357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5358             # (and so on)
5359 113901         983390  
5360 0 50       0 # \u \l \U \L \F \Q \E
5361 484         1189 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5362             if ($right_e < $left_e) {
5363             $char[$i] = '\\' . $char[$i];
5364             }
5365             }
5366             elsif ($char[$i] eq '\u') {
5367              
5368             # "STRING @{[ LIST EXPR ]} MORE STRING"
5369              
5370             # P.257 Other Tricks You Can Do with Hard References
5371             # in Chapter 8: References
5372             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5373              
5374             # P.353 Other Tricks You Can Do with Hard References
5375             # in Chapter 8: References
5376             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5377              
5378 0         0 # (and so on)
5379 0         0  
5380             $char[$i] = '@{[Elatin2::ucfirst qq<';
5381             $left_e++;
5382 0         0 }
5383 0         0 elsif ($char[$i] eq '\l') {
5384             $char[$i] = '@{[Elatin2::lcfirst qq<';
5385             $left_e++;
5386 0         0 }
5387 0         0 elsif ($char[$i] eq '\U') {
5388             $char[$i] = '@{[Elatin2::uc qq<';
5389             $left_e++;
5390 0         0 }
5391 0         0 elsif ($char[$i] eq '\L') {
5392             $char[$i] = '@{[Elatin2::lc qq<';
5393             $left_e++;
5394 0         0 }
5395 24         32 elsif ($char[$i] eq '\F') {
5396             $char[$i] = '@{[Elatin2::fc qq<';
5397             $left_e++;
5398 24         44 }
5399 0         0 elsif ($char[$i] eq '\Q') {
5400             $char[$i] = '@{[CORE::quotemeta qq<';
5401             $left_e++;
5402 0 50       0 }
5403 24         43 elsif ($char[$i] eq '\E') {
5404 24         30 if ($right_e < $left_e) {
5405             $char[$i] = '>]}';
5406             $right_e++;
5407 24         42 }
5408             else {
5409             $char[$i] = '';
5410             }
5411 0         0 }
5412 0 0       0 elsif ($char[$i] eq '\Q') {
5413 0         0 while (1) {
5414             if (++$i > $#char) {
5415 0 0       0 last;
5416 0         0 }
5417             if ($char[$i] eq '\E') {
5418             last;
5419             }
5420             }
5421             }
5422             elsif ($char[$i] eq '\E') {
5423             }
5424              
5425             # $0 --> $0
5426             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5427             }
5428             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5429             }
5430              
5431             # $$ --> $$
5432             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5433             }
5434              
5435             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5436 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5437             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5438             $char[$i] = e_capture($1);
5439 205         441 }
5440             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5441             $char[$i] = e_capture($1);
5442             }
5443              
5444 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5445             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5446             $char[$i] = e_capture($1.'->'.$2);
5447             }
5448              
5449 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5450             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5451             $char[$i] = e_capture($1.'->'.$2);
5452             }
5453              
5454 0         0 # $$foo
5455             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5456             $char[$i] = e_capture($1);
5457             }
5458              
5459 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
5460             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5461             $char[$i] = '@{[Elatin2::PREMATCH()]}';
5462             }
5463              
5464 44         121 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
5465             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5466             $char[$i] = '@{[Elatin2::MATCH()]}';
5467             }
5468              
5469 45         125 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
5470             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5471             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
5472             }
5473              
5474             # ${ foo } --> ${ foo }
5475             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5476             }
5477              
5478 33         93 # ${ ... }
5479             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5480             $char[$i] = e_capture($1);
5481             }
5482             }
5483 0 50       0  
5484 4086         8801 # return string
5485             if ($left_e > $right_e) {
5486 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5487             }
5488             return join '', $ope, $delimiter, @char, $end_delimiter;
5489             }
5490              
5491             #
5492             # escape qw string (qw//)
5493 4086     16 0 35917 #
5494             sub e_qw {
5495 16         95 my($ope,$delimiter,$end_delimiter,$string) = @_;
5496              
5497             $slash = 'div';
5498 16         53  
  16         225  
5499 483 50       789 # choice again delimiter
    0          
    0          
    0          
    0          
5500 16         99 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5501             if (not $octet{$end_delimiter}) {
5502             return join '', $ope, $delimiter, $string, $end_delimiter;
5503 16         135 }
5504             elsif (not $octet{')'}) {
5505             return join '', $ope, '(', $string, ')';
5506 0         0 }
5507             elsif (not $octet{'}'}) {
5508             return join '', $ope, '{', $string, '}';
5509 0         0 }
5510             elsif (not $octet{']'}) {
5511             return join '', $ope, '[', $string, ']';
5512 0         0 }
5513             elsif (not $octet{'>'}) {
5514             return join '', $ope, '<', $string, '>';
5515 0         0 }
5516 0 0       0 else {
5517 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5518             if (not $octet{$char}) {
5519             return join '', $ope, $char, $string, $char;
5520             }
5521             }
5522             }
5523 0         0  
5524 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5525 0         0 my @string = CORE::split(/\s+/, $string);
5526 0         0 for my $string (@string) {
5527 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5528 0         0 for my $octet (@octet) {
5529             if ($octet =~ /\A (['\\]) \z/oxms) {
5530             $octet = '\\' . $1;
5531 0         0 }
5532             }
5533 0         0 $string = join '', @octet;
  0         0  
5534             }
5535             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5536             }
5537              
5538             #
5539             # escape here document (<<"HEREDOC", <
5540 0     93 0 0 #
5541             sub e_heredoc {
5542 93         269 my($string) = @_;
5543              
5544 93         161 $slash = 'm//';
5545              
5546 93         392 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5547 93         150  
5548             my $left_e = 0;
5549             my $right_e = 0;
5550 93         135  
5551             # split regexp
5552             my @char = $string =~ /\G((?>
5553             [^\\\$] |
5554             \\x\{ (?>[0-9A-Fa-f]+) \} |
5555             \\o\{ (?>[0-7]+) \} |
5556             \\N\{ (?>[^0-9\}][^\}]*) \} |
5557             \\ $q_char |
5558             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5559             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5560             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5561             \$ (?>\s* [0-9]+) |
5562             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5563             \$ \$ (?![\w\{]) |
5564             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5565             $q_char
5566 93         8934 ))/oxmsg;
5567              
5568             for (my $i=0; $i <= $#char; $i++) {
5569 93 50 33     424  
    50 33        
    100          
    100          
    50          
5570 3177         11023 # "\L\u" --> "\u\L"
5571             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5572             @char[$i,$i+1] = @char[$i+1,$i];
5573             }
5574              
5575 0         0 # "\U\l" --> "\l\U"
5576             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5577             @char[$i,$i+1] = @char[$i+1,$i];
5578             }
5579              
5580 0         0 # octal escape sequence
5581             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5582             $char[$i] = Elatin2::octchr($1);
5583             }
5584              
5585 1         3 # hexadecimal escape sequence
5586             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5587             $char[$i] = Elatin2::hexchr($1);
5588             }
5589              
5590 1         3 # \N{CHARNAME} --> N{CHARNAME}
5591             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5592             $char[$i] = $1;
5593 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5594              
5595             if (0) {
5596             }
5597 3177         28327  
5598 0 0       0 # \u \l \U \L \F \Q \E
5599 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5600             if ($right_e < $left_e) {
5601             $char[$i] = '\\' . $char[$i];
5602             }
5603 0         0 }
5604 0         0 elsif ($char[$i] eq '\u') {
5605             $char[$i] = '@{[Elatin2::ucfirst qq<';
5606             $left_e++;
5607 0         0 }
5608 0         0 elsif ($char[$i] eq '\l') {
5609             $char[$i] = '@{[Elatin2::lcfirst qq<';
5610             $left_e++;
5611 0         0 }
5612 0         0 elsif ($char[$i] eq '\U') {
5613             $char[$i] = '@{[Elatin2::uc qq<';
5614             $left_e++;
5615 0         0 }
5616 0         0 elsif ($char[$i] eq '\L') {
5617             $char[$i] = '@{[Elatin2::lc qq<';
5618             $left_e++;
5619 0         0 }
5620 0         0 elsif ($char[$i] eq '\F') {
5621             $char[$i] = '@{[Elatin2::fc qq<';
5622             $left_e++;
5623 0         0 }
5624 0         0 elsif ($char[$i] eq '\Q') {
5625             $char[$i] = '@{[CORE::quotemeta qq<';
5626             $left_e++;
5627 0 0       0 }
5628 0         0 elsif ($char[$i] eq '\E') {
5629 0         0 if ($right_e < $left_e) {
5630             $char[$i] = '>]}';
5631             $right_e++;
5632 0         0 }
5633             else {
5634             $char[$i] = '';
5635             }
5636 0         0 }
5637 0 0       0 elsif ($char[$i] eq '\Q') {
5638 0         0 while (1) {
5639             if (++$i > $#char) {
5640 0 0       0 last;
5641 0         0 }
5642             if ($char[$i] eq '\E') {
5643             last;
5644             }
5645             }
5646             }
5647             elsif ($char[$i] eq '\E') {
5648             }
5649              
5650             # $0 --> $0
5651             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5652             }
5653             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5654             }
5655              
5656             # $$ --> $$
5657             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5658             }
5659              
5660             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5661 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5662             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5663             $char[$i] = e_capture($1);
5664 0         0 }
5665             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5666             $char[$i] = e_capture($1);
5667             }
5668              
5669 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5670             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5671             $char[$i] = e_capture($1.'->'.$2);
5672             }
5673              
5674 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5675             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5676             $char[$i] = e_capture($1.'->'.$2);
5677             }
5678              
5679 0         0 # $$foo
5680             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5681             $char[$i] = e_capture($1);
5682             }
5683              
5684 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
5685             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5686             $char[$i] = '@{[Elatin2::PREMATCH()]}';
5687             }
5688              
5689 8         44 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
5690             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5691             $char[$i] = '@{[Elatin2::MATCH()]}';
5692             }
5693              
5694 8         41 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
5695             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5696             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
5697             }
5698              
5699             # ${ foo } --> ${ foo }
5700             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5701             }
5702              
5703 6         33 # ${ ... }
5704             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5705             $char[$i] = e_capture($1);
5706             }
5707             }
5708 0 50       0  
5709 93         219 # return string
5710             if ($left_e > $right_e) {
5711 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5712             }
5713             return join '', @char;
5714             }
5715              
5716             #
5717             # escape regexp (m//, qr//)
5718 93     652 0 802 #
5719 652   100     2680 sub e_qr {
5720             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5721 652         2605 $modifier ||= '';
5722 652 50       1247  
5723 652         1945 $modifier =~ tr/p//d;
5724 0         0 if ($modifier =~ /([adlu])/oxms) {
5725 0 0       0 my $line = 0;
5726 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5727 0         0 if ($filename ne __FILE__) {
5728             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5729             last;
5730 0         0 }
5731             }
5732             die qq{Unsupported modifier "$1" used at line $line.\n};
5733 0         0 }
5734              
5735             $slash = 'div';
5736 652 100       1129  
    100          
5737 652         1919 # literal null string pattern
5738 8         9 if ($string eq '') {
5739 8         10 $modifier =~ tr/bB//d;
5740             $modifier =~ tr/i//d;
5741             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5742             }
5743              
5744             # /b /B modifier
5745             elsif ($modifier =~ tr/bB//d) {
5746 8 50       36  
5747 2         8 # choice again delimiter
5748 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5749 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5750 0         0 my %octet = map {$_ => 1} @char;
5751 0         0 if (not $octet{')'}) {
5752             $delimiter = '(';
5753             $end_delimiter = ')';
5754 0         0 }
5755 0         0 elsif (not $octet{'}'}) {
5756             $delimiter = '{';
5757             $end_delimiter = '}';
5758 0         0 }
5759 0         0 elsif (not $octet{']'}) {
5760             $delimiter = '[';
5761             $end_delimiter = ']';
5762 0         0 }
5763 0         0 elsif (not $octet{'>'}) {
5764             $delimiter = '<';
5765             $end_delimiter = '>';
5766 0         0 }
5767 0 0       0 else {
5768 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5769 0         0 if (not $octet{$char}) {
5770 0         0 $delimiter = $char;
5771             $end_delimiter = $char;
5772             last;
5773             }
5774             }
5775             }
5776 0 50 33     0 }
5777 2         10  
5778             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5779             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5780 0         0 }
5781             else {
5782             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5783             }
5784 2 100       13 }
5785 642         1591  
5786             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5787             my $metachar = qr/[\@\\|[\]{^]/oxms;
5788 642         2553  
5789             # split regexp
5790             my @char = $string =~ /\G((?>
5791             [^\\\$\@\[\(] |
5792             \\x (?>[0-9A-Fa-f]{1,2}) |
5793             \\ (?>[0-7]{2,3}) |
5794             \\c [\x40-\x5F] |
5795             \\x\{ (?>[0-9A-Fa-f]+) \} |
5796             \\o\{ (?>[0-7]+) \} |
5797             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5798             \\ $q_char |
5799             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5800             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5801             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5802             [\$\@] $qq_variable |
5803             \$ (?>\s* [0-9]+) |
5804             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5805             \$ \$ (?![\w\{]) |
5806             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5807             \[\^ |
5808             \[\: (?>[a-z]+) :\] |
5809             \[\:\^ (?>[a-z]+) :\] |
5810             \(\? |
5811             $q_char
5812             ))/oxmsg;
5813 642 50       75222  
5814 642         3071 # choice again delimiter
  0         0  
5815 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5816 0         0 my %octet = map {$_ => 1} @char;
5817 0         0 if (not $octet{')'}) {
5818             $delimiter = '(';
5819             $end_delimiter = ')';
5820 0         0 }
5821 0         0 elsif (not $octet{'}'}) {
5822             $delimiter = '{';
5823             $end_delimiter = '}';
5824 0         0 }
5825 0         0 elsif (not $octet{']'}) {
5826             $delimiter = '[';
5827             $end_delimiter = ']';
5828 0         0 }
5829 0         0 elsif (not $octet{'>'}) {
5830             $delimiter = '<';
5831             $end_delimiter = '>';
5832 0         0 }
5833 0 0       0 else {
5834 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5835 0         0 if (not $octet{$char}) {
5836 0         0 $delimiter = $char;
5837             $end_delimiter = $char;
5838             last;
5839             }
5840             }
5841             }
5842 0         0 }
5843 642         1012  
5844 642         905 my $left_e = 0;
5845             my $right_e = 0;
5846             for (my $i=0; $i <= $#char; $i++) {
5847 642 50 66     1724  
    50 66        
    100          
    100          
    100          
    100          
5848 1872         9654 # "\L\u" --> "\u\L"
5849             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5850             @char[$i,$i+1] = @char[$i+1,$i];
5851             }
5852              
5853 0         0 # "\U\l" --> "\l\U"
5854             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5855             @char[$i,$i+1] = @char[$i+1,$i];
5856             }
5857              
5858 0         0 # octal escape sequence
5859             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5860             $char[$i] = Elatin2::octchr($1);
5861             }
5862              
5863 1         4 # hexadecimal escape sequence
5864             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5865             $char[$i] = Elatin2::hexchr($1);
5866             }
5867              
5868             # \b{...} --> b\{...}
5869             # \B{...} --> B\{...}
5870             # \N{CHARNAME} --> N\{CHARNAME}
5871             # \p{PROPERTY} --> p\{PROPERTY}
5872 1         4 # \P{PROPERTY} --> P\{PROPERTY}
5873             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5874             $char[$i] = $1 . '\\' . $2;
5875             }
5876              
5877 6         21 # \p, \P, \X --> p, P, X
5878             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5879             $char[$i] = $1;
5880 4 100 100     11 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5881              
5882             if (0) {
5883             }
5884 1872         7036  
5885 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5886 6         91 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5887             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)) {
5888             $char[$i] .= join '', splice @char, $i+1, 3;
5889 0         0 }
5890             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)) {
5891             $char[$i] .= join '', splice @char, $i+1, 2;
5892 0         0 }
5893             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)) {
5894             $char[$i] .= join '', splice @char, $i+1, 1;
5895             }
5896             }
5897              
5898 0         0 # open character class [...]
5899             elsif ($char[$i] eq '[') {
5900             my $left = $i;
5901              
5902             # [] make die "Unmatched [] in regexp ...\n"
5903 328 100       426 # (and so on)
5904 328         750  
5905             if ($char[$i+1] eq ']') {
5906             $i++;
5907 3         5 }
5908 328 50       396  
5909 1379         2191 while (1) {
5910             if (++$i > $#char) {
5911 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5912 1379         2237 }
5913             if ($char[$i] eq ']') {
5914             my $right = $i;
5915 328 100       405  
5916 328         1811 # [...]
  30         73  
5917             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5918             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin2::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5919 90         147 }
5920             else {
5921             splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
5922 298         1096 }
5923 328         565  
5924             $i = $left;
5925             last;
5926             }
5927             }
5928             }
5929              
5930 328         787 # open character class [^...]
5931             elsif ($char[$i] eq '[^') {
5932             my $left = $i;
5933              
5934             # [^] make die "Unmatched [] in regexp ...\n"
5935 74 100       102 # (and so on)
5936 74         162  
5937             if ($char[$i+1] eq ']') {
5938             $i++;
5939 4         4 }
5940 74 50       95  
5941 272         385 while (1) {
5942             if (++$i > $#char) {
5943 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5944 272         533 }
5945             if ($char[$i] eq ']') {
5946             my $right = $i;
5947 74 100       109  
5948 74         491 # [^...]
  30         73  
5949             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5950             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin2::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5951 90         224 }
5952             else {
5953             splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5954 44         242 }
5955 74         138  
5956             $i = $left;
5957             last;
5958             }
5959             }
5960             }
5961              
5962 74         184 # rewrite character class or escape character
5963             elsif (my $char = character_class($char[$i],$modifier)) {
5964             $char[$i] = $char;
5965             }
5966              
5967 139 50       357 # /i modifier
5968 20         35 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
5969             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
5970             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
5971 20         33 }
5972             else {
5973             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
5974             }
5975             }
5976              
5977 0 50       0 # \u \l \U \L \F \Q \E
5978 1         4 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5979             if ($right_e < $left_e) {
5980             $char[$i] = '\\' . $char[$i];
5981             }
5982 0         0 }
5983 0         0 elsif ($char[$i] eq '\u') {
5984             $char[$i] = '@{[Elatin2::ucfirst qq<';
5985             $left_e++;
5986 0         0 }
5987 0         0 elsif ($char[$i] eq '\l') {
5988             $char[$i] = '@{[Elatin2::lcfirst qq<';
5989             $left_e++;
5990 0         0 }
5991 1         4 elsif ($char[$i] eq '\U') {
5992             $char[$i] = '@{[Elatin2::uc qq<';
5993             $left_e++;
5994 1         4 }
5995 1         4 elsif ($char[$i] eq '\L') {
5996             $char[$i] = '@{[Elatin2::lc qq<';
5997             $left_e++;
5998 1         3 }
5999 18         62 elsif ($char[$i] eq '\F') {
6000             $char[$i] = '@{[Elatin2::fc qq<';
6001             $left_e++;
6002 18         45 }
6003 1         2 elsif ($char[$i] eq '\Q') {
6004             $char[$i] = '@{[CORE::quotemeta qq<';
6005             $left_e++;
6006 1 50       3 }
6007 21         49 elsif ($char[$i] eq '\E') {
6008 21         26 if ($right_e < $left_e) {
6009             $char[$i] = '>]}';
6010             $right_e++;
6011 21         46 }
6012             else {
6013             $char[$i] = '';
6014             }
6015 0         0 }
6016 0 0       0 elsif ($char[$i] eq '\Q') {
6017 0         0 while (1) {
6018             if (++$i > $#char) {
6019 0 0       0 last;
6020 0         0 }
6021             if ($char[$i] eq '\E') {
6022             last;
6023             }
6024             }
6025             }
6026             elsif ($char[$i] eq '\E') {
6027             }
6028              
6029 0 0       0 # $0 --> $0
6030 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6031             if ($ignorecase) {
6032             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6033             }
6034 0 0       0 }
6035 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6036             if ($ignorecase) {
6037             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6038             }
6039             }
6040              
6041             # $$ --> $$
6042             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6043             }
6044              
6045             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6046 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6047 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6048 0         0 $char[$i] = e_capture($1);
6049             if ($ignorecase) {
6050             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6051             }
6052 0         0 }
6053 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6054 0         0 $char[$i] = e_capture($1);
6055             if ($ignorecase) {
6056             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6057             }
6058             }
6059              
6060 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6061 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6062 0         0 $char[$i] = e_capture($1.'->'.$2);
6063             if ($ignorecase) {
6064             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6065             }
6066             }
6067              
6068 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6069 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6070 0         0 $char[$i] = e_capture($1.'->'.$2);
6071             if ($ignorecase) {
6072             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6073             }
6074             }
6075              
6076 0         0 # $$foo
6077 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6078 0         0 $char[$i] = e_capture($1);
6079             if ($ignorecase) {
6080             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6081             }
6082             }
6083              
6084 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
6085 8         21 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6086             if ($ignorecase) {
6087             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::PREMATCH())]}';
6088 0         0 }
6089             else {
6090             $char[$i] = '@{[Elatin2::PREMATCH()]}';
6091             }
6092             }
6093              
6094 8 50       25 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
6095 8         20 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6096             if ($ignorecase) {
6097             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::MATCH())]}';
6098 0         0 }
6099             else {
6100             $char[$i] = '@{[Elatin2::MATCH()]}';
6101             }
6102             }
6103              
6104 8 50       25 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
6105 6         18 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6106             if ($ignorecase) {
6107             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::POSTMATCH())]}';
6108 0         0 }
6109             else {
6110             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
6111             }
6112             }
6113              
6114 6 0       17 # ${ foo }
6115 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6116             if ($ignorecase) {
6117             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6118             }
6119             }
6120              
6121 0         0 # ${ ... }
6122 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6123 0         0 $char[$i] = e_capture($1);
6124             if ($ignorecase) {
6125             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6126             }
6127             }
6128              
6129 0         0 # $scalar or @array
6130 21 100       59 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6131 21         123 $char[$i] = e_string($char[$i]);
6132             if ($ignorecase) {
6133             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6134             }
6135             }
6136              
6137 11 100 33     36 # quote character before ? + * {
    50          
6138             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6139             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6140 138         991 }
6141 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6142 0         0 my $char = $char[$i-1];
6143             if ($char[$i] eq '{') {
6144             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6145 0         0 }
6146             else {
6147             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6148             }
6149 0         0 }
6150             else {
6151             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6152             }
6153             }
6154             }
6155 127         474  
6156 642 50       1155 # make regexp string
6157 642 0 0     1421 $modifier =~ tr/i//d;
6158 0         0 if ($left_e > $right_e) {
6159             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6160             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6161 0         0 }
6162             else {
6163             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6164 0 50 33     0 }
6165 642         3473 }
6166             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6167             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6168 0         0 }
6169             else {
6170             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6171             }
6172             }
6173              
6174             #
6175             # double quote stuff
6176 642     180 0 5309 #
6177             sub qq_stuff {
6178             my($delimiter,$end_delimiter,$stuff) = @_;
6179 180 100       272  
6180 180         410 # scalar variable or array variable
6181             if ($stuff =~ /\A [\$\@] /oxms) {
6182             return $stuff;
6183             }
6184 100         347  
  80         187  
6185 80         430 # quote by delimiter
6186 80 50       218 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6187 80 50       148 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6188 80 50       122 next if $char eq $delimiter;
6189 80         148 next if $char eq $end_delimiter;
6190             if (not $octet{$char}) {
6191             return join '', 'qq', $char, $stuff, $char;
6192 80         306 }
6193             }
6194             return join '', 'qq', '<', $stuff, '>';
6195             }
6196              
6197             #
6198             # escape regexp (m'', qr'', and m''b, qr''b)
6199 0     10 0 0 #
6200 10   50     46 sub e_qr_q {
6201             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6202 10         45 $modifier ||= '';
6203 10 50       15  
6204 10         19 $modifier =~ tr/p//d;
6205 0         0 if ($modifier =~ /([adlu])/oxms) {
6206 0 0       0 my $line = 0;
6207 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6208 0         0 if ($filename ne __FILE__) {
6209             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6210             last;
6211 0         0 }
6212             }
6213             die qq{Unsupported modifier "$1" used at line $line.\n};
6214 0         0 }
6215              
6216             $slash = 'div';
6217 10 100       15  
    50          
6218 10         23 # literal null string pattern
6219 8         11 if ($string eq '') {
6220 8         10 $modifier =~ tr/bB//d;
6221             $modifier =~ tr/i//d;
6222             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6223             }
6224              
6225 8         39 # with /b /B modifier
6226             elsif ($modifier =~ tr/bB//d) {
6227             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6228             }
6229              
6230 0         0 # without /b /B modifier
6231             else {
6232             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6233             }
6234             }
6235              
6236             #
6237             # escape regexp (m'', qr'')
6238 2     2 0 7 #
6239             sub e_qr_qt {
6240 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6241              
6242             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6243 2         5  
6244             # split regexp
6245             my @char = $string =~ /\G((?>
6246             [^\\\[\$\@\/] |
6247             [\x00-\xFF] |
6248             \[\^ |
6249             \[\: (?>[a-z]+) \:\] |
6250             \[\:\^ (?>[a-z]+) \:\] |
6251             [\$\@\/] |
6252             \\ (?:$q_char) |
6253             (?:$q_char)
6254             ))/oxmsg;
6255 2         60  
6256 2 50 33     11 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6257             for (my $i=0; $i <= $#char; $i++) {
6258             if (0) {
6259             }
6260 2         14  
6261 0         0 # open character class [...]
6262 0 0       0 elsif ($char[$i] eq '[') {
6263 0         0 my $left = $i;
6264             if ($char[$i+1] eq ']') {
6265 0         0 $i++;
6266 0 0       0 }
6267 0         0 while (1) {
6268             if (++$i > $#char) {
6269 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6270 0         0 }
6271             if ($char[$i] eq ']') {
6272             my $right = $i;
6273 0         0  
6274             # [...]
6275 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
6276 0         0  
6277             $i = $left;
6278             last;
6279             }
6280             }
6281             }
6282              
6283 0         0 # open character class [^...]
6284 0 0       0 elsif ($char[$i] eq '[^') {
6285 0         0 my $left = $i;
6286             if ($char[$i+1] eq ']') {
6287 0         0 $i++;
6288 0 0       0 }
6289 0         0 while (1) {
6290             if (++$i > $#char) {
6291 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6292 0         0 }
6293             if ($char[$i] eq ']') {
6294             my $right = $i;
6295 0         0  
6296             # [^...]
6297 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6298 0         0  
6299             $i = $left;
6300             last;
6301             }
6302             }
6303             }
6304              
6305 0         0 # escape $ @ / and \
6306             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6307             $char[$i] = '\\' . $char[$i];
6308             }
6309              
6310 0         0 # rewrite character class or escape character
6311             elsif (my $char = character_class($char[$i],$modifier)) {
6312             $char[$i] = $char;
6313             }
6314              
6315 0 0       0 # /i modifier
6316 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
6317             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
6318             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
6319 0         0 }
6320             else {
6321             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
6322             }
6323             }
6324              
6325 0 0       0 # quote character before ? + * {
6326             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6327             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6328 0         0 }
6329             else {
6330             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6331             }
6332             }
6333 0         0 }
6334 2         5  
6335             $delimiter = '/';
6336 2         3 $end_delimiter = '/';
6337 2         4  
6338             $modifier =~ tr/i//d;
6339             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6340             }
6341              
6342             #
6343             # escape regexp (m''b, qr''b)
6344 2     0 0 14 #
6345             sub e_qr_qb {
6346             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6347 0         0  
6348             # split regexp
6349             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6350 0         0  
6351 0 0       0 # unescape character
    0          
6352             for (my $i=0; $i <= $#char; $i++) {
6353             if (0) {
6354             }
6355 0         0  
6356             # remain \\
6357             elsif ($char[$i] eq '\\\\') {
6358             }
6359              
6360 0         0 # escape $ @ / and \
6361             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6362             $char[$i] = '\\' . $char[$i];
6363             }
6364 0         0 }
6365 0         0  
6366 0         0 $delimiter = '/';
6367             $end_delimiter = '/';
6368             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6369             }
6370              
6371             #
6372             # escape regexp (s/here//)
6373 0     76 0 0 #
6374 76   100     366 sub e_s1 {
6375             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6376 76         329 $modifier ||= '';
6377 76 50       126  
6378 76         213 $modifier =~ tr/p//d;
6379 0         0 if ($modifier =~ /([adlu])/oxms) {
6380 0 0       0 my $line = 0;
6381 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6382 0         0 if ($filename ne __FILE__) {
6383             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6384             last;
6385 0         0 }
6386             }
6387             die qq{Unsupported modifier "$1" used at line $line.\n};
6388 0         0 }
6389              
6390             $slash = 'div';
6391 76 100       258  
    50          
6392 76         265 # literal null string pattern
6393 8         8 if ($string eq '') {
6394 8         16 $modifier =~ tr/bB//d;
6395             $modifier =~ tr/i//d;
6396             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6397             }
6398              
6399             # /b /B modifier
6400             elsif ($modifier =~ tr/bB//d) {
6401 8 0       47  
6402 0         0 # choice again delimiter
6403 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6404 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6405 0         0 my %octet = map {$_ => 1} @char;
6406 0         0 if (not $octet{')'}) {
6407             $delimiter = '(';
6408             $end_delimiter = ')';
6409 0         0 }
6410 0         0 elsif (not $octet{'}'}) {
6411             $delimiter = '{';
6412             $end_delimiter = '}';
6413 0         0 }
6414 0         0 elsif (not $octet{']'}) {
6415             $delimiter = '[';
6416             $end_delimiter = ']';
6417 0         0 }
6418 0         0 elsif (not $octet{'>'}) {
6419             $delimiter = '<';
6420             $end_delimiter = '>';
6421 0         0 }
6422 0 0       0 else {
6423 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6424 0         0 if (not $octet{$char}) {
6425 0         0 $delimiter = $char;
6426             $end_delimiter = $char;
6427             last;
6428             }
6429             }
6430             }
6431 0         0 }
6432 0         0  
6433             my $prematch = '';
6434             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6435 0 100       0 }
6436 68         371  
6437             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6438             my $metachar = qr/[\@\\|[\]{^]/oxms;
6439 68         305  
6440             # split regexp
6441             my @char = $string =~ /\G((?>
6442             [^\\\$\@\[\(] |
6443             \\ (?>[1-9][0-9]*) |
6444             \\g (?>\s*) (?>[1-9][0-9]*) |
6445             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6446             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6447             \\x (?>[0-9A-Fa-f]{1,2}) |
6448             \\ (?>[0-7]{2,3}) |
6449             \\c [\x40-\x5F] |
6450             \\x\{ (?>[0-9A-Fa-f]+) \} |
6451             \\o\{ (?>[0-7]+) \} |
6452             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6453             \\ $q_char |
6454             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6455             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6456             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6457             [\$\@] $qq_variable |
6458             \$ (?>\s* [0-9]+) |
6459             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6460             \$ \$ (?![\w\{]) |
6461             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6462             \[\^ |
6463             \[\: (?>[a-z]+) :\] |
6464             \[\:\^ (?>[a-z]+) :\] |
6465             \(\? |
6466             $q_char
6467             ))/oxmsg;
6468 68 50       37223  
6469 68         571 # choice again delimiter
  0         0  
6470 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6471 0         0 my %octet = map {$_ => 1} @char;
6472 0         0 if (not $octet{')'}) {
6473             $delimiter = '(';
6474             $end_delimiter = ')';
6475 0         0 }
6476 0         0 elsif (not $octet{'}'}) {
6477             $delimiter = '{';
6478             $end_delimiter = '}';
6479 0         0 }
6480 0         0 elsif (not $octet{']'}) {
6481             $delimiter = '[';
6482             $end_delimiter = ']';
6483 0         0 }
6484 0         0 elsif (not $octet{'>'}) {
6485             $delimiter = '<';
6486             $end_delimiter = '>';
6487 0         0 }
6488 0 0       0 else {
6489 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6490 0         0 if (not $octet{$char}) {
6491 0         0 $delimiter = $char;
6492             $end_delimiter = $char;
6493             last;
6494             }
6495             }
6496             }
6497             }
6498 0         0  
  68         166  
6499             # count '('
6500 253         430 my $parens = grep { $_ eq '(' } @char;
6501 68         111  
6502 68         111 my $left_e = 0;
6503             my $right_e = 0;
6504             for (my $i=0; $i <= $#char; $i++) {
6505 68 50 33     210  
    50 33        
    100          
    100          
    50          
    50          
6506 195         1832 # "\L\u" --> "\u\L"
6507             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6508             @char[$i,$i+1] = @char[$i+1,$i];
6509             }
6510              
6511 0         0 # "\U\l" --> "\l\U"
6512             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6513             @char[$i,$i+1] = @char[$i+1,$i];
6514             }
6515              
6516 0         0 # octal escape sequence
6517             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6518             $char[$i] = Elatin2::octchr($1);
6519             }
6520              
6521 1         4 # hexadecimal escape sequence
6522             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6523             $char[$i] = Elatin2::hexchr($1);
6524             }
6525              
6526             # \b{...} --> b\{...}
6527             # \B{...} --> B\{...}
6528             # \N{CHARNAME} --> N\{CHARNAME}
6529             # \p{PROPERTY} --> p\{PROPERTY}
6530 1         5 # \P{PROPERTY} --> P\{PROPERTY}
6531             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6532             $char[$i] = $1 . '\\' . $2;
6533             }
6534              
6535 0         0 # \p, \P, \X --> p, P, X
6536             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6537             $char[$i] = $1;
6538 0 50 66     0 }
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6539              
6540             if (0) {
6541             }
6542 195         929  
6543 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6544 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6545             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)) {
6546             $char[$i] .= join '', splice @char, $i+1, 3;
6547 0         0 }
6548             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)) {
6549             $char[$i] .= join '', splice @char, $i+1, 2;
6550 0         0 }
6551             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)) {
6552             $char[$i] .= join '', splice @char, $i+1, 1;
6553             }
6554             }
6555              
6556 0         0 # open character class [...]
6557 13 50       39 elsif ($char[$i] eq '[') {
6558 13         68 my $left = $i;
6559             if ($char[$i+1] eq ']') {
6560 0         0 $i++;
6561 13 50       20 }
6562 58         88 while (1) {
6563             if (++$i > $#char) {
6564 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6565 58         126 }
6566             if ($char[$i] eq ']') {
6567             my $right = $i;
6568 13 50       21  
6569 13         83 # [...]
  0         0  
6570             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6571             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin2::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6572 0         0 }
6573             else {
6574             splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
6575 13         57 }
6576 13         25  
6577             $i = $left;
6578             last;
6579             }
6580             }
6581             }
6582              
6583 13         35 # open character class [^...]
6584 0 0       0 elsif ($char[$i] eq '[^') {
6585 0         0 my $left = $i;
6586             if ($char[$i+1] eq ']') {
6587 0         0 $i++;
6588 0 0       0 }
6589 0         0 while (1) {
6590             if (++$i > $#char) {
6591 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6592 0         0 }
6593             if ($char[$i] eq ']') {
6594             my $right = $i;
6595 0 0       0  
6596 0         0 # [^...]
  0         0  
6597             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6598             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin2::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6599 0         0 }
6600             else {
6601             splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6602 0         0 }
6603 0         0  
6604             $i = $left;
6605             last;
6606             }
6607             }
6608             }
6609              
6610 0         0 # rewrite character class or escape character
6611             elsif (my $char = character_class($char[$i],$modifier)) {
6612             $char[$i] = $char;
6613             }
6614              
6615 7 50       14 # /i modifier
6616 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
6617             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
6618             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
6619 3         14 }
6620             else {
6621             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
6622             }
6623             }
6624              
6625 0 0       0 # \u \l \U \L \F \Q \E
6626 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6627             if ($right_e < $left_e) {
6628             $char[$i] = '\\' . $char[$i];
6629             }
6630 0         0 }
6631 0         0 elsif ($char[$i] eq '\u') {
6632             $char[$i] = '@{[Elatin2::ucfirst qq<';
6633             $left_e++;
6634 0         0 }
6635 0         0 elsif ($char[$i] eq '\l') {
6636             $char[$i] = '@{[Elatin2::lcfirst qq<';
6637             $left_e++;
6638 0         0 }
6639 0         0 elsif ($char[$i] eq '\U') {
6640             $char[$i] = '@{[Elatin2::uc qq<';
6641             $left_e++;
6642 0         0 }
6643 0         0 elsif ($char[$i] eq '\L') {
6644             $char[$i] = '@{[Elatin2::lc qq<';
6645             $left_e++;
6646 0         0 }
6647 0         0 elsif ($char[$i] eq '\F') {
6648             $char[$i] = '@{[Elatin2::fc qq<';
6649             $left_e++;
6650 0         0 }
6651 0         0 elsif ($char[$i] eq '\Q') {
6652             $char[$i] = '@{[CORE::quotemeta qq<';
6653             $left_e++;
6654 0 0       0 }
6655 0         0 elsif ($char[$i] eq '\E') {
6656 0         0 if ($right_e < $left_e) {
6657             $char[$i] = '>]}';
6658             $right_e++;
6659 0         0 }
6660             else {
6661             $char[$i] = '';
6662             }
6663 0         0 }
6664 0 0       0 elsif ($char[$i] eq '\Q') {
6665 0         0 while (1) {
6666             if (++$i > $#char) {
6667 0 0       0 last;
6668 0         0 }
6669             if ($char[$i] eq '\E') {
6670             last;
6671             }
6672             }
6673             }
6674             elsif ($char[$i] eq '\E') {
6675             }
6676              
6677             # \0 --> \0
6678             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6679             }
6680              
6681             # \g{N}, \g{-N}
6682              
6683             # P.108 Using Simple Patterns
6684             # in Chapter 7: In the World of Regular Expressions
6685             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6686              
6687             # P.221 Capturing
6688             # in Chapter 5: Pattern Matching
6689             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6690              
6691             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6692             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6693             }
6694              
6695             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6696             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6697             }
6698              
6699             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6700             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6701             }
6702              
6703             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6704             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6705             }
6706              
6707 0 0       0 # $0 --> $0
6708 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6709             if ($ignorecase) {
6710             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6711             }
6712 0 0       0 }
6713 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6714             if ($ignorecase) {
6715             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6716             }
6717             }
6718              
6719             # $$ --> $$
6720             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6721             }
6722              
6723             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6724 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6725 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6726 0         0 $char[$i] = e_capture($1);
6727             if ($ignorecase) {
6728             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6729             }
6730 0         0 }
6731 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6732 0         0 $char[$i] = e_capture($1);
6733             if ($ignorecase) {
6734             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6735             }
6736             }
6737              
6738 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6739 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6740 0         0 $char[$i] = e_capture($1.'->'.$2);
6741             if ($ignorecase) {
6742             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6743             }
6744             }
6745              
6746 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6747 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6748 0         0 $char[$i] = e_capture($1.'->'.$2);
6749             if ($ignorecase) {
6750             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6751             }
6752             }
6753              
6754 0         0 # $$foo
6755 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6756 0         0 $char[$i] = e_capture($1);
6757             if ($ignorecase) {
6758             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6759             }
6760             }
6761              
6762 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
6763 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6764             if ($ignorecase) {
6765             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::PREMATCH())]}';
6766 0         0 }
6767             else {
6768             $char[$i] = '@{[Elatin2::PREMATCH()]}';
6769             }
6770             }
6771              
6772 4 50       13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
6773 4         13 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6774             if ($ignorecase) {
6775             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::MATCH())]}';
6776 0         0 }
6777             else {
6778             $char[$i] = '@{[Elatin2::MATCH()]}';
6779             }
6780             }
6781              
6782 4 50       16 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
6783 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6784             if ($ignorecase) {
6785             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::POSTMATCH())]}';
6786 0         0 }
6787             else {
6788             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
6789             }
6790             }
6791              
6792 3 0       11 # ${ foo }
6793 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6794             if ($ignorecase) {
6795             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6796             }
6797             }
6798              
6799 0         0 # ${ ... }
6800 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6801 0         0 $char[$i] = e_capture($1);
6802             if ($ignorecase) {
6803             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6804             }
6805             }
6806              
6807 0         0 # $scalar or @array
6808 4 50       31 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6809 4         25 $char[$i] = e_string($char[$i]);
6810             if ($ignorecase) {
6811             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6812             }
6813             }
6814              
6815 0 50       0 # quote character before ? + * {
6816             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6817             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6818 13         70 }
6819             else {
6820             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6821             }
6822             }
6823             }
6824 13         69  
6825 68         169 # make regexp string
6826 68 50       238 my $prematch = '';
6827 68         180 $modifier =~ tr/i//d;
6828             if ($left_e > $right_e) {
6829 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6830             }
6831             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6832             }
6833              
6834             #
6835             # escape regexp (s'here'' or s'here''b)
6836 68     21 0 792 #
6837 21   100     53 sub e_s1_q {
6838             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6839 21         69 $modifier ||= '';
6840 21 50       29  
6841 21         46 $modifier =~ tr/p//d;
6842 0         0 if ($modifier =~ /([adlu])/oxms) {
6843 0 0       0 my $line = 0;
6844 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6845 0         0 if ($filename ne __FILE__) {
6846             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6847             last;
6848 0         0 }
6849             }
6850             die qq{Unsupported modifier "$1" used at line $line.\n};
6851 0         0 }
6852              
6853             $slash = 'div';
6854 21 100       29  
    50          
6855 21         54 # literal null string pattern
6856 8         9 if ($string eq '') {
6857 8         9 $modifier =~ tr/bB//d;
6858             $modifier =~ tr/i//d;
6859             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6860             }
6861              
6862 8         47 # with /b /B modifier
6863             elsif ($modifier =~ tr/bB//d) {
6864             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6865             }
6866              
6867 0         0 # without /b /B modifier
6868             else {
6869             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6870             }
6871             }
6872              
6873             #
6874             # escape regexp (s'here'')
6875 13     13 0 30 #
6876             sub e_s1_qt {
6877 13 50       28 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6878              
6879             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6880 13         26  
6881             # split regexp
6882             my @char = $string =~ /\G((?>
6883             [^\\\[\$\@\/] |
6884             [\x00-\xFF] |
6885             \[\^ |
6886             \[\: (?>[a-z]+) \:\] |
6887             \[\:\^ (?>[a-z]+) \:\] |
6888             [\$\@\/] |
6889             \\ (?:$q_char) |
6890             (?:$q_char)
6891             ))/oxmsg;
6892 13         189  
6893 13 50 33     41 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6894             for (my $i=0; $i <= $#char; $i++) {
6895             if (0) {
6896             }
6897 25         97  
6898 0         0 # open character class [...]
6899 0 0       0 elsif ($char[$i] eq '[') {
6900 0         0 my $left = $i;
6901             if ($char[$i+1] eq ']') {
6902 0         0 $i++;
6903 0 0       0 }
6904 0         0 while (1) {
6905             if (++$i > $#char) {
6906 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6907 0         0 }
6908             if ($char[$i] eq ']') {
6909             my $right = $i;
6910 0         0  
6911             # [...]
6912 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
6913 0         0  
6914             $i = $left;
6915             last;
6916             }
6917             }
6918             }
6919              
6920 0         0 # open character class [^...]
6921 0 0       0 elsif ($char[$i] eq '[^') {
6922 0         0 my $left = $i;
6923             if ($char[$i+1] eq ']') {
6924 0         0 $i++;
6925 0 0       0 }
6926 0         0 while (1) {
6927             if (++$i > $#char) {
6928 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6929 0         0 }
6930             if ($char[$i] eq ']') {
6931             my $right = $i;
6932 0         0  
6933             # [^...]
6934 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6935 0         0  
6936             $i = $left;
6937             last;
6938             }
6939             }
6940             }
6941              
6942 0         0 # escape $ @ / and \
6943             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6944             $char[$i] = '\\' . $char[$i];
6945             }
6946              
6947 0         0 # rewrite character class or escape character
6948             elsif (my $char = character_class($char[$i],$modifier)) {
6949             $char[$i] = $char;
6950             }
6951              
6952 6 0       11 # /i modifier
6953 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
6954             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
6955             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
6956 0         0 }
6957             else {
6958             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
6959             }
6960             }
6961              
6962 0 0       0 # quote character before ? + * {
6963             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6964             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6965 0         0 }
6966             else {
6967             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6968             }
6969             }
6970 0         0 }
6971 13         23  
6972 13         22 $modifier =~ tr/i//d;
6973 13         20 $delimiter = '/';
6974 13         18 $end_delimiter = '/';
6975             my $prematch = '';
6976             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6977             }
6978              
6979             #
6980             # escape regexp (s'here''b)
6981 13     0 0 88 #
6982             sub e_s1_qb {
6983             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6984 0         0  
6985             # split regexp
6986             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6987 0         0  
6988 0 0       0 # unescape character
    0          
6989             for (my $i=0; $i <= $#char; $i++) {
6990             if (0) {
6991             }
6992 0         0  
6993             # remain \\
6994             elsif ($char[$i] eq '\\\\') {
6995             }
6996              
6997 0         0 # escape $ @ / and \
6998             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6999             $char[$i] = '\\' . $char[$i];
7000             }
7001 0         0 }
7002 0         0  
7003 0         0 $delimiter = '/';
7004 0         0 $end_delimiter = '/';
7005             my $prematch = '';
7006             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7007             }
7008              
7009             #
7010             # escape regexp (s''here')
7011 0     16 0 0 #
7012             sub e_s2_q {
7013 16         43 my($ope,$delimiter,$end_delimiter,$string) = @_;
7014              
7015 16         21 $slash = 'div';
7016 16         93  
7017 16 100       42 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7018             for (my $i=0; $i <= $#char; $i++) {
7019             if (0) {
7020             }
7021 9         30  
7022             # not escape \\
7023             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7024             }
7025              
7026 0         0 # escape $ @ / and \
7027             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7028             $char[$i] = '\\' . $char[$i];
7029             }
7030 5         13 }
7031              
7032             return join '', $ope, $delimiter, @char, $end_delimiter;
7033             }
7034              
7035             #
7036             # escape regexp (s/here/and here/modifier)
7037 16     97 0 47 #
7038 97   100     816 sub e_sub {
7039             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7040 97         441 $modifier ||= '';
7041 97 50       193  
7042 97         316 $modifier =~ tr/p//d;
7043 0         0 if ($modifier =~ /([adlu])/oxms) {
7044 0 0       0 my $line = 0;
7045 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7046 0         0 if ($filename ne __FILE__) {
7047             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7048             last;
7049 0         0 }
7050             }
7051             die qq{Unsupported modifier "$1" used at line $line.\n};
7052 0 100       0 }
7053 97         250  
7054 36         46 if ($variable eq '') {
7055             $variable = '$_';
7056             $bind_operator = ' =~ ';
7057 36         45 }
7058              
7059             $slash = 'div';
7060              
7061             # P.128 Start of match (or end of previous match): \G
7062             # P.130 Advanced Use of \G with Perl
7063             # in Chapter 3: Overview of Regular Expression Features and Flavors
7064             # P.312 Iterative Matching: Scalar Context, with /g
7065             # in Chapter 7: Perl
7066             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7067              
7068             # P.181 Where You Left Off: The \G Assertion
7069             # in Chapter 5: Pattern Matching
7070             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7071              
7072             # P.220 Where You Left Off: The \G Assertion
7073             # in Chapter 5: Pattern Matching
7074 97         163 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7075 97         151  
7076             my $e_modifier = $modifier =~ tr/e//d;
7077 97         238 my $r_modifier = $modifier =~ tr/r//d;
7078 97 50       150  
7079 97         268 my $my = '';
7080 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7081 0         0 $my = $variable;
7082             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7083             $variable =~ s/ = .+ \z//oxms;
7084 0         0 }
7085 97         278  
7086             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7087             $variable_basename =~ s/ \s+ \z//oxms;
7088 97         190  
7089 97 100       148 # quote replacement string
7090 97         229 my $e_replacement = '';
7091 17         32 if ($e_modifier >= 1) {
7092             $e_replacement = e_qq('', '', '', $replacement);
7093             $e_modifier--;
7094 17 100       21 }
7095 80         194 else {
7096             if ($delimiter2 eq "'") {
7097             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7098 16         32 }
7099             else {
7100             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7101             }
7102 64         180 }
7103              
7104             my $sub = '';
7105 97 100       169  
7106 97 100       260 # with /r
7107             if ($r_modifier) {
7108             if (0) {
7109             }
7110 8         27  
7111 0 50       0 # s///gr without multibyte anchoring
7112             elsif ($modifier =~ /g/oxms) {
7113             $sub = sprintf(
7114             # 1 2 3 4 5
7115             q,
7116              
7117             $variable, # 1
7118             ($delimiter1 eq "'") ? # 2
7119             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7120             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7121             $s_matched, # 3
7122             $e_replacement, # 4
7123             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 5
7124             );
7125             }
7126              
7127             # s///r
7128 4         20 else {
7129              
7130 4 50       6 my $prematch = q{$`};
7131              
7132             $sub = sprintf(
7133             # 1 2 3 4 5 6 7
7134             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin2::re_r=%s; %s"%s$Elatin2::re_r$'" } : %s>,
7135              
7136             $variable, # 1
7137             ($delimiter1 eq "'") ? # 2
7138             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7139             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7140             $s_matched, # 3
7141             $e_replacement, # 4
7142             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 5
7143             $prematch, # 6
7144             $variable, # 7
7145             );
7146             }
7147 4 50       19  
7148 8         27 # $var !~ s///r doesn't make sense
7149             if ($bind_operator =~ / !~ /oxms) {
7150             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7151             }
7152             }
7153              
7154 0 100       0 # without /r
7155             else {
7156             if (0) {
7157             }
7158 89         252  
7159 0 100       0 # s///g without multibyte anchoring
    100          
7160             elsif ($modifier =~ /g/oxms) {
7161             $sub = sprintf(
7162             # 1 2 3 4 5 6 7 8
7163             q,
7164              
7165             $variable, # 1
7166             ($delimiter1 eq "'") ? # 2
7167             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7168             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7169             $s_matched, # 3
7170             $e_replacement, # 4
7171             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 5
7172             $variable, # 6
7173             $variable, # 7
7174             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7175             );
7176             }
7177              
7178             # s///
7179 22         724 else {
7180              
7181 67 100       208 my $prematch = q{$`};
    100          
7182              
7183             $sub = sprintf(
7184              
7185             ($bind_operator =~ / =~ /oxms) ?
7186              
7187             # 1 2 3 4 5 6 7 8
7188             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin2::re_r=%s; %s%s="%s$Elatin2::re_r$'"; 1 } : undef> :
7189              
7190             # 1 2 3 4 5 6 7 8
7191             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin2::re_r=%s; %s%s="%s$Elatin2::re_r$'"; undef }>,
7192              
7193             $variable, # 1
7194             $bind_operator, # 2
7195             ($delimiter1 eq "'") ? # 3
7196             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7197             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7198             $s_matched, # 4
7199             $e_replacement, # 5
7200             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 6
7201             $variable, # 7
7202             $prematch, # 8
7203             );
7204             }
7205             }
7206 67 50       415  
7207 97         280 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7208             if ($my ne '') {
7209             $sub = "($my, $sub)[1]";
7210             }
7211 0         0  
7212 97         167 # clear s/// variable
7213             $sub_variable = '';
7214 97         427 $bind_operator = '';
7215              
7216             return $sub;
7217             }
7218              
7219             #
7220             # escape regexp of split qr//
7221 97     74 0 907 #
7222 74   100     355 sub e_split {
7223             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7224 74         349 $modifier ||= '';
7225 74 50       121  
7226 74         291 $modifier =~ tr/p//d;
7227 0         0 if ($modifier =~ /([adlu])/oxms) {
7228 0 0       0 my $line = 0;
7229 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7230 0         0 if ($filename ne __FILE__) {
7231             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7232             last;
7233 0         0 }
7234             }
7235             die qq{Unsupported modifier "$1" used at line $line.\n};
7236 0         0 }
7237              
7238             $slash = 'div';
7239 74 50       183  
7240 74         188 # /b /B modifier
7241             if ($modifier =~ tr/bB//d) {
7242             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7243 0 50       0 }
7244 74         935  
7245             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7246             my $metachar = qr/[\@\\|[\]{^]/oxms;
7247 74         319  
7248             # split regexp
7249             my @char = $string =~ /\G((?>
7250             [^\\\$\@\[\(] |
7251             \\x (?>[0-9A-Fa-f]{1,2}) |
7252             \\ (?>[0-7]{2,3}) |
7253             \\c [\x40-\x5F] |
7254             \\x\{ (?>[0-9A-Fa-f]+) \} |
7255             \\o\{ (?>[0-7]+) \} |
7256             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7257             \\ $q_char |
7258             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7259             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7260             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7261             [\$\@] $qq_variable |
7262             \$ (?>\s* [0-9]+) |
7263             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7264             \$ \$ (?![\w\{]) |
7265             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7266             \[\^ |
7267             \[\: (?>[a-z]+) :\] |
7268             \[\:\^ (?>[a-z]+) :\] |
7269             \(\? |
7270             $q_char
7271 74         9229 ))/oxmsg;
7272 74         248  
7273 74         107 my $left_e = 0;
7274             my $right_e = 0;
7275             for (my $i=0; $i <= $#char; $i++) {
7276 74 50 33     380  
    50 33        
    100          
    100          
    50          
    50          
7277 249         1330 # "\L\u" --> "\u\L"
7278             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7279             @char[$i,$i+1] = @char[$i+1,$i];
7280             }
7281              
7282 0         0 # "\U\l" --> "\l\U"
7283             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7284             @char[$i,$i+1] = @char[$i+1,$i];
7285             }
7286              
7287 0         0 # octal escape sequence
7288             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7289             $char[$i] = Elatin2::octchr($1);
7290             }
7291              
7292 1         4 # hexadecimal escape sequence
7293             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7294             $char[$i] = Elatin2::hexchr($1);
7295             }
7296              
7297             # \b{...} --> b\{...}
7298             # \B{...} --> B\{...}
7299             # \N{CHARNAME} --> N\{CHARNAME}
7300             # \p{PROPERTY} --> p\{PROPERTY}
7301 1         4 # \P{PROPERTY} --> P\{PROPERTY}
7302             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7303             $char[$i] = $1 . '\\' . $2;
7304             }
7305              
7306 0         0 # \p, \P, \X --> p, P, X
7307             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7308             $char[$i] = $1;
7309 0 50 100     0 }
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7310              
7311             if (0) {
7312             }
7313 249         938  
7314 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7315 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7316             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)) {
7317             $char[$i] .= join '', splice @char, $i+1, 3;
7318 0         0 }
7319             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)) {
7320             $char[$i] .= join '', splice @char, $i+1, 2;
7321 0         0 }
7322             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)) {
7323             $char[$i] .= join '', splice @char, $i+1, 1;
7324             }
7325             }
7326              
7327 0         0 # open character class [...]
7328 3 50       8 elsif ($char[$i] eq '[') {
7329 3         11 my $left = $i;
7330             if ($char[$i+1] eq ']') {
7331 0         0 $i++;
7332 3 50       4 }
7333 7         14 while (1) {
7334             if (++$i > $#char) {
7335 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7336 7         16 }
7337             if ($char[$i] eq ']') {
7338             my $right = $i;
7339 3 50       5  
7340 3         19 # [...]
  0         0  
7341             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7342             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin2::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7343 0         0 }
7344             else {
7345             splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
7346 3         14 }
7347 3         5  
7348             $i = $left;
7349             last;
7350             }
7351             }
7352             }
7353              
7354 3         7 # open character class [^...]
7355 0 0       0 elsif ($char[$i] eq '[^') {
7356 0         0 my $left = $i;
7357             if ($char[$i+1] eq ']') {
7358 0         0 $i++;
7359 0 0       0 }
7360 0         0 while (1) {
7361             if (++$i > $#char) {
7362 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7363 0         0 }
7364             if ($char[$i] eq ']') {
7365             my $right = $i;
7366 0 0       0  
7367 0         0 # [^...]
  0         0  
7368             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7369             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin2::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7370 0         0 }
7371             else {
7372             splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7373 0         0 }
7374 0         0  
7375             $i = $left;
7376             last;
7377             }
7378             }
7379             }
7380              
7381 0         0 # rewrite character class or escape character
7382             elsif (my $char = character_class($char[$i],$modifier)) {
7383             $char[$i] = $char;
7384             }
7385              
7386             # P.794 29.2.161. split
7387             # in Chapter 29: Functions
7388             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7389              
7390             # P.951 split
7391             # in Chapter 27: Functions
7392             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7393              
7394             # said "The //m modifier is assumed when you split on the pattern /^/",
7395             # but perl5.008 is not so. Therefore, this software adds //m.
7396             # (and so on)
7397              
7398 1         3 # split(m/^/) --> split(m/^/m)
7399             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7400             $modifier .= 'm';
7401             }
7402              
7403 7 0       20 # /i modifier
7404 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
7405             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
7406             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
7407 0         0 }
7408             else {
7409             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
7410             }
7411             }
7412              
7413 0 0       0 # \u \l \U \L \F \Q \E
7414 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7415             if ($right_e < $left_e) {
7416             $char[$i] = '\\' . $char[$i];
7417             }
7418 0         0 }
7419 0         0 elsif ($char[$i] eq '\u') {
7420             $char[$i] = '@{[Elatin2::ucfirst qq<';
7421             $left_e++;
7422 0         0 }
7423 0         0 elsif ($char[$i] eq '\l') {
7424             $char[$i] = '@{[Elatin2::lcfirst qq<';
7425             $left_e++;
7426 0         0 }
7427 0         0 elsif ($char[$i] eq '\U') {
7428             $char[$i] = '@{[Elatin2::uc qq<';
7429             $left_e++;
7430 0         0 }
7431 0         0 elsif ($char[$i] eq '\L') {
7432             $char[$i] = '@{[Elatin2::lc qq<';
7433             $left_e++;
7434 0         0 }
7435 0         0 elsif ($char[$i] eq '\F') {
7436             $char[$i] = '@{[Elatin2::fc qq<';
7437             $left_e++;
7438 0         0 }
7439 0         0 elsif ($char[$i] eq '\Q') {
7440             $char[$i] = '@{[CORE::quotemeta qq<';
7441             $left_e++;
7442 0 0       0 }
7443 0         0 elsif ($char[$i] eq '\E') {
7444 0         0 if ($right_e < $left_e) {
7445             $char[$i] = '>]}';
7446             $right_e++;
7447 0         0 }
7448             else {
7449             $char[$i] = '';
7450             }
7451 0         0 }
7452 0 0       0 elsif ($char[$i] eq '\Q') {
7453 0         0 while (1) {
7454             if (++$i > $#char) {
7455 0 0       0 last;
7456 0         0 }
7457             if ($char[$i] eq '\E') {
7458             last;
7459             }
7460             }
7461             }
7462             elsif ($char[$i] eq '\E') {
7463             }
7464              
7465 0 0       0 # $0 --> $0
7466 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7467             if ($ignorecase) {
7468             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7469             }
7470 0 0       0 }
7471 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7472             if ($ignorecase) {
7473             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7474             }
7475             }
7476              
7477             # $$ --> $$
7478             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7479             }
7480              
7481             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7482 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7483 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7484 0         0 $char[$i] = e_capture($1);
7485             if ($ignorecase) {
7486             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7487             }
7488 0         0 }
7489 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7490 0         0 $char[$i] = e_capture($1);
7491             if ($ignorecase) {
7492             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7493             }
7494             }
7495              
7496 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7497 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7498 0         0 $char[$i] = e_capture($1.'->'.$2);
7499             if ($ignorecase) {
7500             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7501             }
7502             }
7503              
7504 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7505 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7506 0         0 $char[$i] = e_capture($1.'->'.$2);
7507             if ($ignorecase) {
7508             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7509             }
7510             }
7511              
7512 0         0 # $$foo
7513 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7514 0         0 $char[$i] = e_capture($1);
7515             if ($ignorecase) {
7516             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7517             }
7518             }
7519              
7520 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
7521 12         33 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7522             if ($ignorecase) {
7523             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::PREMATCH())]}';
7524 0         0 }
7525             else {
7526             $char[$i] = '@{[Elatin2::PREMATCH()]}';
7527             }
7528             }
7529              
7530 12 50       56 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
7531 12         39 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7532             if ($ignorecase) {
7533             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::MATCH())]}';
7534 0         0 }
7535             else {
7536             $char[$i] = '@{[Elatin2::MATCH()]}';
7537             }
7538             }
7539              
7540 12 50       53 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
7541 9         25 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7542             if ($ignorecase) {
7543             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::POSTMATCH())]}';
7544 0         0 }
7545             else {
7546             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
7547             }
7548             }
7549              
7550 9 0       39 # ${ foo }
7551 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7552             if ($ignorecase) {
7553             $char[$i] = '@{[Elatin2::ignorecase(' . $1 . ')]}';
7554             }
7555             }
7556              
7557 0         0 # ${ ... }
7558 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7559 0         0 $char[$i] = e_capture($1);
7560             if ($ignorecase) {
7561             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7562             }
7563             }
7564              
7565 0         0 # $scalar or @array
7566 3 50       13 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7567 3         17 $char[$i] = e_string($char[$i]);
7568             if ($ignorecase) {
7569             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7570             }
7571             }
7572              
7573 0 50       0 # quote character before ? + * {
7574             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7575             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7576 1         7 }
7577             else {
7578             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7579             }
7580             }
7581             }
7582 0         0  
7583 74 50       213 # make regexp string
7584 74         167 $modifier =~ tr/i//d;
7585             if ($left_e > $right_e) {
7586 0         0 return join '', 'Elatin2::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7587             }
7588             return join '', 'Elatin2::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7589             }
7590              
7591             #
7592             # escape regexp of split qr''
7593 74     0 0 723 #
7594 0   0       sub e_split_q {
7595             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7596 0           $modifier ||= '';
7597 0 0          
7598 0           $modifier =~ tr/p//d;
7599 0           if ($modifier =~ /([adlu])/oxms) {
7600 0 0         my $line = 0;
7601 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7602 0           if ($filename ne __FILE__) {
7603             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7604             last;
7605 0           }
7606             }
7607             die qq{Unsupported modifier "$1" used at line $line.\n};
7608 0           }
7609              
7610             $slash = 'div';
7611 0 0          
7612 0           # /b /B modifier
7613             if ($modifier =~ tr/bB//d) {
7614             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7615 0 0         }
7616              
7617             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7618 0            
7619             # split regexp
7620             my @char = $string =~ /\G((?>
7621             [^\\\[] |
7622             [\x00-\xFF] |
7623             \[\^ |
7624             \[\: (?>[a-z]+) \:\] |
7625             \[\:\^ (?>[a-z]+) \:\] |
7626             \\ (?:$q_char) |
7627             (?:$q_char)
7628             ))/oxmsg;
7629 0            
7630 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7631             for (my $i=0; $i <= $#char; $i++) {
7632             if (0) {
7633             }
7634 0            
7635 0           # open character class [...]
7636 0 0         elsif ($char[$i] eq '[') {
7637 0           my $left = $i;
7638             if ($char[$i+1] eq ']') {
7639 0           $i++;
7640 0 0         }
7641 0           while (1) {
7642             if (++$i > $#char) {
7643 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7644 0           }
7645             if ($char[$i] eq ']') {
7646             my $right = $i;
7647 0            
7648             # [...]
7649 0           splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
7650 0            
7651             $i = $left;
7652             last;
7653             }
7654             }
7655             }
7656              
7657 0           # open character class [^...]
7658 0 0         elsif ($char[$i] eq '[^') {
7659 0           my $left = $i;
7660             if ($char[$i+1] eq ']') {
7661 0           $i++;
7662 0 0         }
7663 0           while (1) {
7664             if (++$i > $#char) {
7665 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7666 0           }
7667             if ($char[$i] eq ']') {
7668             my $right = $i;
7669 0            
7670             # [^...]
7671 0           splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7672 0            
7673             $i = $left;
7674             last;
7675             }
7676             }
7677             }
7678              
7679 0           # rewrite character class or escape character
7680             elsif (my $char = character_class($char[$i],$modifier)) {
7681             $char[$i] = $char;
7682             }
7683              
7684 0           # split(m/^/) --> split(m/^/m)
7685             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7686             $modifier .= 'm';
7687             }
7688              
7689 0 0         # /i modifier
7690 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
7691             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
7692             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
7693 0           }
7694             else {
7695             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
7696             }
7697             }
7698              
7699 0 0         # quote character before ? + * {
7700             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7701             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7702 0           }
7703             else {
7704             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7705             }
7706             }
7707 0           }
7708 0            
7709             $modifier =~ tr/i//d;
7710             return join '', 'Elatin2::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7711             }
7712              
7713             #
7714             # instead of Carp::carp
7715 0     0 0   #
7716 0           sub carp {
7717             my($package,$filename,$line) = caller(1);
7718             print STDERR "@_ at $filename line $line.\n";
7719             }
7720              
7721             #
7722             # instead of Carp::croak
7723 0     0 0   #
7724 0           sub croak {
7725 0           my($package,$filename,$line) = caller(1);
7726             print STDERR "@_ at $filename line $line.\n";
7727             die "\n";
7728             }
7729              
7730             #
7731             # instead of Carp::cluck
7732 0     0 0   #
7733 0           sub cluck {
7734 0           my $i = 0;
7735 0           my @cluck = ();
7736 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7737             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7738 0           $i++;
7739 0           }
7740 0           print STDERR CORE::reverse @cluck;
7741             print STDERR "\n";
7742             print STDERR @_;
7743             }
7744              
7745             #
7746             # instead of Carp::confess
7747 0     0 0   #
7748 0           sub confess {
7749 0           my $i = 0;
7750 0           my @confess = ();
7751 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7752             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7753 0           $i++;
7754 0           }
7755 0           print STDERR CORE::reverse @confess;
7756 0           print STDERR "\n";
7757             print STDERR @_;
7758             die "\n";
7759             }
7760              
7761             1;
7762              
7763             __END__