File Coverage

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


line stmt bran cond sub pod time code
1             package Elatin2;
2 204     204   1525 use strict;
  204         321  
  204         6107  
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   2650 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         641  
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   1029 use vars qw($VERSION);
  204         454  
  204         27831  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1657 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         387 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         26766 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   16149 CORE::eval q{
  204     204   1306  
  204     60   492  
  204         24637  
  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       79985 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     0 0 0 my($name) = @_;
78              
79 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
80 0         0 return $name;
81             }
82             elsif (Elatin2::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Elatin2::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 0         0 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 0   0 0 0 if (defined $_[1]) {
117 204     204   1446 no strict qw(refs);
  204         365  
  204         13831  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   1185 no strict qw(refs);
  204     0   380  
  204         38862  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x00-\xFF]};
153 204     204   1323 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         336  
  204         14787  
154 204     204   1244 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         533  
  204         395713  
155              
156             #
157             # Latin-2 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Latin-2 case conversion
163             #
164             my %lc = ();
165             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
166             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
167             my %uc = ();
168             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
169             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
170             my %fc = ();
171             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
172             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Elatin2 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xA1" => "\xB1", # LATIN LETTER A WITH OGONEK
185             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
186             "\xA5" => "\xB5", # LATIN LETTER L WITH CARON
187             "\xA6" => "\xB6", # LATIN LETTER S WITH ACUTE
188             "\xA9" => "\xB9", # LATIN LETTER S WITH CARON
189             "\xAA" => "\xBA", # LATIN LETTER S WITH CEDILLA
190             "\xAB" => "\xBB", # LATIN LETTER T WITH CARON
191             "\xAC" => "\xBC", # LATIN LETTER Z WITH ACUTE
192             "\xAE" => "\xBE", # LATIN LETTER Z WITH CARON
193             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
194             "\xC0" => "\xE0", # LATIN LETTER R WITH ACUTE
195             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
196             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
197             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
198             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
199             "\xC5" => "\xE5", # LATIN LETTER L WITH ACUTE
200             "\xC6" => "\xE6", # LATIN LETTER C WITH ACUTE
201             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
202             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
203             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
204             "\xCA" => "\xEA", # LATIN LETTER E WITH OGONEK
205             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
206             "\xCC" => "\xEC", # LATIN LETTER E WITH CARON
207             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
208             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
209             "\xCF" => "\xEF", # LATIN LETTER D WITH CARON
210             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
211             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
212             "\xD2" => "\xF2", # LATIN LETTER N WITH CARON
213             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
214             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
215             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
216             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
217             "\xD8" => "\xF8", # LATIN LETTER R WITH CARON
218             "\xD9" => "\xF9", # LATIN LETTER U WITH RING ABOVE
219             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
220             "\xDB" => "\xFB", # LATIN LETTER U WITH DOUBLE ACUTE
221             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
222             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
223             "\xDE" => "\xFE", # LATIN LETTER T WITH CEDILLA
224             );
225              
226             %uc = (%uc,
227             "\xB1" => "\xA1", # LATIN LETTER A WITH OGONEK
228             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
229             "\xB5" => "\xA5", # LATIN LETTER L WITH CARON
230             "\xB6" => "\xA6", # LATIN LETTER S WITH ACUTE
231             "\xB9" => "\xA9", # LATIN LETTER S WITH CARON
232             "\xBA" => "\xAA", # LATIN LETTER S WITH CEDILLA
233             "\xBB" => "\xAB", # LATIN LETTER T WITH CARON
234             "\xBC" => "\xAC", # LATIN LETTER Z WITH ACUTE
235             "\xBE" => "\xAE", # LATIN LETTER Z WITH CARON
236             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
237             "\xE0" => "\xC0", # LATIN LETTER R WITH ACUTE
238             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
239             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
240             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
241             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
242             "\xE5" => "\xC5", # LATIN LETTER L WITH ACUTE
243             "\xE6" => "\xC6", # LATIN LETTER C WITH ACUTE
244             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
245             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
246             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
247             "\xEA" => "\xCA", # LATIN LETTER E WITH OGONEK
248             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
249             "\xEC" => "\xCC", # LATIN LETTER E WITH CARON
250             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
251             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
252             "\xEF" => "\xCF", # LATIN LETTER D WITH CARON
253             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
254             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
255             "\xF2" => "\xD2", # LATIN LETTER N WITH CARON
256             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
257             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
258             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
259             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
260             "\xF8" => "\xD8", # LATIN LETTER R WITH CARON
261             "\xF9" => "\xD9", # LATIN LETTER U WITH RING ABOVE
262             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
263             "\xFB" => "\xDB", # LATIN LETTER U WITH DOUBLE ACUTE
264             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
265             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
266             "\xFE" => "\xDE", # LATIN LETTER T WITH CEDILLA
267             );
268              
269             %fc = (%fc,
270             "\xA1" => "\xB1", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
271             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
272             "\xA5" => "\xB5", # LATIN CAPITAL LETTER L WITH CARON --> LATIN SMALL LETTER L WITH CARON
273             "\xA6" => "\xB6", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
274             "\xA9" => "\xB9", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
275             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH CEDILLA --> LATIN SMALL LETTER S WITH CEDILLA
276             "\xAB" => "\xBB", # LATIN CAPITAL LETTER T WITH CARON --> LATIN SMALL LETTER T WITH CARON
277             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
278             "\xAE" => "\xBE", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
279             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
280             "\xC0" => "\xE0", # LATIN CAPITAL LETTER R WITH ACUTE --> LATIN SMALL LETTER R WITH ACUTE
281             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
282             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
283             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
284             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
285             "\xC5" => "\xE5", # LATIN CAPITAL LETTER L WITH ACUTE --> LATIN SMALL LETTER L WITH ACUTE
286             "\xC6" => "\xE6", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
287             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
288             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
289             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
290             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
291             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
292             "\xCC" => "\xEC", # LATIN CAPITAL LETTER E WITH CARON --> LATIN SMALL LETTER E WITH CARON
293             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
294             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
295             "\xCF" => "\xEF", # LATIN CAPITAL LETTER D WITH CARON --> LATIN SMALL LETTER D WITH CARON
296             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
297             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
298             "\xD2" => "\xF2", # LATIN CAPITAL LETTER N WITH CARON --> LATIN SMALL LETTER N WITH CARON
299             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
300             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
301             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
302             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
303             "\xD8" => "\xF8", # LATIN CAPITAL LETTER R WITH CARON --> LATIN SMALL LETTER R WITH CARON
304             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH RING ABOVE --> LATIN SMALL LETTER U WITH RING ABOVE
305             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
306             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
307             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
308             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
309             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH CEDILLA --> LATIN SMALL LETTER T WITH CEDILLA
310             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
311             );
312             }
313              
314             else {
315             croak "Don't know my package name '@{[__PACKAGE__]}'";
316             }
317              
318             #
319             # @ARGV wildcard globbing
320             #
321             sub import {
322              
323 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
324 0         0 my @argv = ();
325 0         0 for (@ARGV) {
326              
327             # has space
328 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
329 0 0       0 if (my @glob = Elatin2::glob(qq{"$_"})) {
330 0         0 push @argv, @glob;
331             }
332             else {
333 0         0 push @argv, $_;
334             }
335             }
336              
337             # has wildcard metachar
338             elsif (/\A (?:$q_char)*? [*?] /oxms) {
339 0 0       0 if (my @glob = Elatin2::glob($_)) {
340 0         0 push @argv, @glob;
341             }
342             else {
343 0         0 push @argv, $_;
344             }
345             }
346              
347             # no wildcard globbing
348             else {
349 0         0 push @argv, $_;
350             }
351             }
352 0         0 @ARGV = @argv;
353             }
354              
355 0         0 *Char::ord = \&Latin2::ord;
356 0         0 *Char::ord_ = \&Latin2::ord_;
357 0         0 *Char::reverse = \&Latin2::reverse;
358 0         0 *Char::getc = \&Latin2::getc;
359 0         0 *Char::length = \&Latin2::length;
360 0         0 *Char::substr = \&Latin2::substr;
361 0         0 *Char::index = \&Latin2::index;
362 0         0 *Char::rindex = \&Latin2::rindex;
363 0         0 *Char::eval = \&Latin2::eval;
364 0         0 *Char::escape = \&Latin2::escape;
365 0         0 *Char::escape_token = \&Latin2::escape_token;
366 0         0 *Char::escape_script = \&Latin2::escape_script;
367             }
368              
369             # P.230 Care with Prototypes
370             # in Chapter 6: Subroutines
371             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
372             #
373             # If you aren't careful, you can get yourself into trouble with prototypes.
374             # But if you are careful, you can do a lot of neat things with them. This is
375             # all very powerful, of course, and should only be used in moderation to make
376             # the world a better place.
377              
378             # P.332 Care with Prototypes
379             # in Chapter 7: Subroutines
380             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
381             #
382             # If you aren't careful, you can get yourself into trouble with prototypes.
383             # But if you are careful, you can do a lot of neat things with them. This is
384             # all very powerful, of course, and should only be used in moderation to make
385             # the world a better place.
386              
387             #
388             # Prototypes of subroutines
389             #
390       0     sub unimport {}
391             sub Elatin2::split(;$$$);
392             sub Elatin2::tr($$$$;$);
393             sub Elatin2::chop(@);
394             sub Elatin2::index($$;$);
395             sub Elatin2::rindex($$;$);
396             sub Elatin2::lcfirst(@);
397             sub Elatin2::lcfirst_();
398             sub Elatin2::lc(@);
399             sub Elatin2::lc_();
400             sub Elatin2::ucfirst(@);
401             sub Elatin2::ucfirst_();
402             sub Elatin2::uc(@);
403             sub Elatin2::uc_();
404             sub Elatin2::fc(@);
405             sub Elatin2::fc_();
406             sub Elatin2::ignorecase;
407             sub Elatin2::classic_character_class;
408             sub Elatin2::capture;
409             sub Elatin2::chr(;$);
410             sub Elatin2::chr_();
411             sub Elatin2::glob($);
412             sub Elatin2::glob_();
413              
414             sub Latin2::ord(;$);
415             sub Latin2::ord_();
416             sub Latin2::reverse(@);
417             sub Latin2::getc(;*@);
418             sub Latin2::length(;$);
419             sub Latin2::substr($$;$$);
420             sub Latin2::index($$;$);
421             sub Latin2::rindex($$;$);
422             sub Latin2::escape(;$);
423              
424             #
425             # Regexp work
426             #
427 204         16884 use vars qw(
428             $re_a
429             $re_t
430             $re_n
431             $re_r
432 204     204   1878 );
  204         397  
433              
434             #
435             # Character class
436             #
437 204         2205562 use vars qw(
438             $dot
439             $dot_s
440             $eD
441             $eS
442             $eW
443             $eH
444             $eV
445             $eR
446             $eN
447             $not_alnum
448             $not_alpha
449             $not_ascii
450             $not_blank
451             $not_cntrl
452             $not_digit
453             $not_graph
454             $not_lower
455             $not_lower_i
456             $not_print
457             $not_punct
458             $not_space
459             $not_upper
460             $not_upper_i
461             $not_word
462             $not_xdigit
463             $eb
464             $eB
465 204     204   1214 );
  204         528  
466              
467             ${Elatin2::dot} = qr{(?>[^\x0A])};
468             ${Elatin2::dot_s} = qr{(?>[\x00-\xFF])};
469             ${Elatin2::eD} = qr{(?>[^0-9])};
470              
471             # Vertical tabs are now whitespace
472             # \s in a regex now matches a vertical tab in all circumstances.
473             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
474             # ${Elatin2::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
475             # ${Elatin2::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
476             ${Elatin2::eS} = qr{(?>[^\s])};
477              
478             ${Elatin2::eW} = qr{(?>[^0-9A-Z_a-z])};
479             ${Elatin2::eH} = qr{(?>[^\x09\x20])};
480             ${Elatin2::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
481             ${Elatin2::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
482             ${Elatin2::eN} = qr{(?>[^\x0A])};
483             ${Elatin2::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
484             ${Elatin2::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
485             ${Elatin2::not_ascii} = qr{(?>[^\x00-\x7F])};
486             ${Elatin2::not_blank} = qr{(?>[^\x09\x20])};
487             ${Elatin2::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
488             ${Elatin2::not_digit} = qr{(?>[^\x30-\x39])};
489             ${Elatin2::not_graph} = qr{(?>[^\x21-\x7F])};
490             ${Elatin2::not_lower} = qr{(?>[^\x61-\x7A])};
491             ${Elatin2::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
492             # ${Elatin2::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
493             ${Elatin2::not_print} = qr{(?>[^\x20-\x7F])};
494             ${Elatin2::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
495             ${Elatin2::not_space} = qr{(?>[^\s\x0B])};
496             ${Elatin2::not_upper} = qr{(?>[^\x41-\x5A])};
497             ${Elatin2::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
498             # ${Elatin2::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
499             ${Elatin2::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
500             ${Elatin2::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
501             ${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))};
502             ${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]))};
503              
504             # avoid: Name "Elatin2::foo" used only once: possible typo at here.
505             ${Elatin2::dot} = ${Elatin2::dot};
506             ${Elatin2::dot_s} = ${Elatin2::dot_s};
507             ${Elatin2::eD} = ${Elatin2::eD};
508             ${Elatin2::eS} = ${Elatin2::eS};
509             ${Elatin2::eW} = ${Elatin2::eW};
510             ${Elatin2::eH} = ${Elatin2::eH};
511             ${Elatin2::eV} = ${Elatin2::eV};
512             ${Elatin2::eR} = ${Elatin2::eR};
513             ${Elatin2::eN} = ${Elatin2::eN};
514             ${Elatin2::not_alnum} = ${Elatin2::not_alnum};
515             ${Elatin2::not_alpha} = ${Elatin2::not_alpha};
516             ${Elatin2::not_ascii} = ${Elatin2::not_ascii};
517             ${Elatin2::not_blank} = ${Elatin2::not_blank};
518             ${Elatin2::not_cntrl} = ${Elatin2::not_cntrl};
519             ${Elatin2::not_digit} = ${Elatin2::not_digit};
520             ${Elatin2::not_graph} = ${Elatin2::not_graph};
521             ${Elatin2::not_lower} = ${Elatin2::not_lower};
522             ${Elatin2::not_lower_i} = ${Elatin2::not_lower_i};
523             ${Elatin2::not_print} = ${Elatin2::not_print};
524             ${Elatin2::not_punct} = ${Elatin2::not_punct};
525             ${Elatin2::not_space} = ${Elatin2::not_space};
526             ${Elatin2::not_upper} = ${Elatin2::not_upper};
527             ${Elatin2::not_upper_i} = ${Elatin2::not_upper_i};
528             ${Elatin2::not_word} = ${Elatin2::not_word};
529             ${Elatin2::not_xdigit} = ${Elatin2::not_xdigit};
530             ${Elatin2::eb} = ${Elatin2::eb};
531             ${Elatin2::eB} = ${Elatin2::eB};
532              
533             #
534             # Latin-2 split
535             #
536             sub Elatin2::split(;$$$) {
537              
538             # P.794 29.2.161. split
539             # in Chapter 29: Functions
540             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
541              
542             # P.951 split
543             # in Chapter 27: Functions
544             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
545              
546 0     0 0 0 my $pattern = $_[0];
547 0         0 my $string = $_[1];
548 0         0 my $limit = $_[2];
549              
550             # if $pattern is also omitted or is the literal space, " "
551 0 0       0 if (not defined $pattern) {
552 0         0 $pattern = ' ';
553             }
554              
555             # if $string is omitted, the function splits the $_ string
556 0 0       0 if (not defined $string) {
557 0 0       0 if (defined $_) {
558 0         0 $string = $_;
559             }
560             else {
561 0         0 $string = '';
562             }
563             }
564              
565 0         0 my @split = ();
566              
567             # when string is empty
568 0 0       0 if ($string eq '') {
    0          
569              
570             # resulting list value in list context
571 0 0       0 if (wantarray) {
572 0         0 return @split;
573             }
574              
575             # count of substrings in scalar context
576             else {
577 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
578 0         0 @_ = @split;
579 0         0 return scalar @_;
580             }
581             }
582              
583             # split's first argument is more consistently interpreted
584             #
585             # After some changes earlier in v5.17, split's behavior has been simplified:
586             # if the PATTERN argument evaluates to a string containing one space, it is
587             # treated the way that a literal string containing one space once was.
588             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
589              
590             # if $pattern is also omitted or is the literal space, " ", the function splits
591             # on whitespace, /\s+/, after skipping any leading whitespace
592             # (and so on)
593              
594             elsif ($pattern eq ' ') {
595 0 0       0 if (not defined $limit) {
596 0         0 return CORE::split(' ', $string);
597             }
598             else {
599 0         0 return CORE::split(' ', $string, $limit);
600             }
601             }
602              
603             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
604 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
605              
606             # a pattern capable of matching either the null string or something longer than the
607             # null string will split the value of $string into separate characters wherever it
608             # matches the null string between characters
609             # (and so on)
610              
611 0 0       0 if ('' =~ / \A $pattern \z /xms) {
612 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
613 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
614              
615             # P.1024 Appendix W.10 Multibyte Processing
616             # of ISBN 1-56592-224-7 CJKV Information Processing
617             # (and so on)
618              
619             # the //m modifier is assumed when you split on the pattern /^/
620             # (and so on)
621              
622             # V
623 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
624              
625             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
626             # is included in the resulting list, interspersed with the fields that are ordinarily returned
627             # (and so on)
628              
629 0         0 local $@;
630 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
631 0         0 push @split, CORE::eval('$' . $digit);
632             }
633             }
634             }
635              
636             else {
637 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
638              
639             # V
640 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
641 0         0 local $@;
642 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
643 0         0 push @split, CORE::eval('$' . $digit);
644             }
645             }
646             }
647             }
648              
649             elsif ($limit > 0) {
650 0 0       0 if ('' =~ / \A $pattern \z /xms) {
651 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
652 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
653              
654             # V
655 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
656 0         0 local $@;
657 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
658 0         0 push @split, CORE::eval('$' . $digit);
659             }
660             }
661             }
662             }
663             else {
664 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
665 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
666              
667             # V
668 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
669 0         0 local $@;
670 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
671 0         0 push @split, CORE::eval('$' . $digit);
672             }
673             }
674             }
675             }
676             }
677              
678 0 0       0 if (CORE::length($string) > 0) {
679 0         0 push @split, $string;
680             }
681              
682             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
683 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
684 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
685 0         0 pop @split;
686             }
687             }
688              
689             # resulting list value in list context
690 0 0       0 if (wantarray) {
691 0         0 return @split;
692             }
693              
694             # count of substrings in scalar context
695             else {
696 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
697 0         0 @_ = @split;
698 0         0 return scalar @_;
699             }
700             }
701              
702             #
703             # get last subexpression offsets
704             #
705             sub _last_subexpression_offsets {
706 0     0   0 my $pattern = $_[0];
707              
708             # remove comment
709 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
710              
711 0         0 my $modifier = '';
712 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
713 0         0 $modifier = $1;
714 0         0 $modifier =~ s/-[A-Za-z]*//;
715             }
716              
717             # with /x modifier
718 0         0 my @char = ();
719 0 0       0 if ($modifier =~ /x/oxms) {
720 0         0 @char = $pattern =~ /\G((?>
721             [^\\\#\[\(] |
722             \\ $q_char |
723             \# (?>[^\n]*) $ |
724             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
725             \(\? |
726             $q_char
727             ))/oxmsg;
728             }
729              
730             # without /x modifier
731             else {
732 0         0 @char = $pattern =~ /\G((?>
733             [^\\\[\(] |
734             \\ $q_char |
735             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
736             \(\? |
737             $q_char
738             ))/oxmsg;
739             }
740              
741 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
742             }
743              
744             #
745             # Latin-2 transliteration (tr///)
746             #
747             sub Elatin2::tr($$$$;$) {
748              
749 0     0 0 0 my $bind_operator = $_[1];
750 0         0 my $searchlist = $_[2];
751 0         0 my $replacementlist = $_[3];
752 0   0     0 my $modifier = $_[4] || '';
753              
754 0 0       0 if ($modifier =~ /r/oxms) {
755 0 0       0 if ($bind_operator =~ / !~ /oxms) {
756 0         0 croak "Using !~ with tr///r doesn't make sense";
757             }
758             }
759              
760 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
761 0         0 my @searchlist = _charlist_tr($searchlist);
762 0         0 my @replacementlist = _charlist_tr($replacementlist);
763              
764 0         0 my %tr = ();
765 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
766 0 0       0 if (not exists $tr{$searchlist[$i]}) {
767 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
768 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
769             }
770             elsif ($modifier =~ /d/oxms) {
771 0         0 $tr{$searchlist[$i]} = '';
772             }
773             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
774 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
775             }
776             else {
777 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
778             }
779             }
780             }
781              
782 0         0 my $tr = 0;
783 0         0 my $replaced = '';
784 0 0       0 if ($modifier =~ /c/oxms) {
785 0         0 while (defined(my $char = shift @char)) {
786 0 0       0 if (not exists $tr{$char}) {
787 0 0       0 if (defined $replacementlist[0]) {
788 0         0 $replaced .= $replacementlist[0];
789             }
790 0         0 $tr++;
791 0 0       0 if ($modifier =~ /s/oxms) {
792 0   0     0 while (@char and (not exists $tr{$char[0]})) {
793 0         0 shift @char;
794 0         0 $tr++;
795             }
796             }
797             }
798             else {
799 0         0 $replaced .= $char;
800             }
801             }
802             }
803             else {
804 0         0 while (defined(my $char = shift @char)) {
805 0 0       0 if (exists $tr{$char}) {
806 0         0 $replaced .= $tr{$char};
807 0         0 $tr++;
808 0 0       0 if ($modifier =~ /s/oxms) {
809 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
810 0         0 shift @char;
811 0         0 $tr++;
812             }
813             }
814             }
815             else {
816 0         0 $replaced .= $char;
817             }
818             }
819             }
820              
821 0 0       0 if ($modifier =~ /r/oxms) {
822 0         0 return $replaced;
823             }
824             else {
825 0         0 $_[0] = $replaced;
826 0 0       0 if ($bind_operator =~ / !~ /oxms) {
827 0         0 return not $tr;
828             }
829             else {
830 0         0 return $tr;
831             }
832             }
833             }
834              
835             #
836             # Latin-2 chop
837             #
838             sub Elatin2::chop(@) {
839              
840 0     0 0 0 my $chop;
841 0 0       0 if (@_ == 0) {
842 0         0 my @char = /\G (?>$q_char) /oxmsg;
843 0         0 $chop = pop @char;
844 0         0 $_ = join '', @char;
845             }
846             else {
847 0         0 for (@_) {
848 0         0 my @char = /\G (?>$q_char) /oxmsg;
849 0         0 $chop = pop @char;
850 0         0 $_ = join '', @char;
851             }
852             }
853 0         0 return $chop;
854             }
855              
856             #
857             # Latin-2 index by octet
858             #
859             sub Elatin2::index($$;$) {
860              
861 0     0 1 0 my($str,$substr,$position) = @_;
862 0   0     0 $position ||= 0;
863 0         0 my $pos = 0;
864              
865 0         0 while ($pos < CORE::length($str)) {
866 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
867 0 0       0 if ($pos >= $position) {
868 0         0 return $pos;
869             }
870             }
871 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
872 0         0 $pos += CORE::length($1);
873             }
874             else {
875 0         0 $pos += 1;
876             }
877             }
878 0         0 return -1;
879             }
880              
881             #
882             # Latin-2 reverse index
883             #
884             sub Elatin2::rindex($$;$) {
885              
886 0     0 0 0 my($str,$substr,$position) = @_;
887 0   0     0 $position ||= CORE::length($str) - 1;
888 0         0 my $pos = 0;
889 0         0 my $rindex = -1;
890              
891 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
892 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
893 0         0 $rindex = $pos;
894             }
895 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
896 0         0 $pos += CORE::length($1);
897             }
898             else {
899 0         0 $pos += 1;
900             }
901             }
902 0         0 return $rindex;
903             }
904              
905             #
906             # Latin-2 lower case first with parameter
907             #
908             sub Elatin2::lcfirst(@) {
909 0 0   0 0 0 if (@_) {
910 0         0 my $s = shift @_;
911 0 0 0     0 if (@_ and wantarray) {
912 0         0 return Elatin2::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
913             }
914             else {
915 0         0 return Elatin2::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
916             }
917             }
918             else {
919 0         0 return Elatin2::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
920             }
921             }
922              
923             #
924             # Latin-2 lower case first without parameter
925             #
926             sub Elatin2::lcfirst_() {
927 0     0 0 0 return Elatin2::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
928             }
929              
930             #
931             # Latin-2 lower case with parameter
932             #
933             sub Elatin2::lc(@) {
934 0 0   0 0 0 if (@_) {
935 0         0 my $s = shift @_;
936 0 0 0     0 if (@_ and wantarray) {
937 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
938             }
939             else {
940 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
941             }
942             }
943             else {
944 0         0 return Elatin2::lc_();
945             }
946             }
947              
948             #
949             # Latin-2 lower case without parameter
950             #
951             sub Elatin2::lc_() {
952 0     0 0 0 my $s = $_;
953 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
954             }
955              
956             #
957             # Latin-2 upper case first with parameter
958             #
959             sub Elatin2::ucfirst(@) {
960 0 0   0 0 0 if (@_) {
961 0         0 my $s = shift @_;
962 0 0 0     0 if (@_ and wantarray) {
963 0         0 return Elatin2::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
964             }
965             else {
966 0         0 return Elatin2::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
967             }
968             }
969             else {
970 0         0 return Elatin2::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
971             }
972             }
973              
974             #
975             # Latin-2 upper case first without parameter
976             #
977             sub Elatin2::ucfirst_() {
978 0     0 0 0 return Elatin2::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
979             }
980              
981             #
982             # Latin-2 upper case with parameter
983             #
984             sub Elatin2::uc(@) {
985 0 50   174 0 0 if (@_) {
986 174         320 my $s = shift @_;
987 174 50 33     216 if (@_ and wantarray) {
988 174 0       367 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
989             }
990             else {
991 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         530  
992             }
993             }
994             else {
995 174         600 return Elatin2::uc_();
996             }
997             }
998              
999             #
1000             # Latin-2 upper case without parameter
1001             #
1002             sub Elatin2::uc_() {
1003 0     0 0 0 my $s = $_;
1004 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1005             }
1006              
1007             #
1008             # Latin-2 fold case with parameter
1009             #
1010             sub Elatin2::fc(@) {
1011 0 50   197 0 0 if (@_) {
1012 197         274 my $s = shift @_;
1013 197 50 33     236 if (@_ and wantarray) {
1014 197 0       331 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1015             }
1016             else {
1017 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         480  
1018             }
1019             }
1020             else {
1021 197         1168 return Elatin2::fc_();
1022             }
1023             }
1024              
1025             #
1026             # Latin-2 fold case without parameter
1027             #
1028             sub Elatin2::fc_() {
1029 0     0 0 0 my $s = $_;
1030 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1031             }
1032              
1033             #
1034             # Latin-2 regexp capture
1035             #
1036             {
1037             sub Elatin2::capture {
1038 0     0 1 0 return $_[0];
1039             }
1040             }
1041              
1042             #
1043             # Latin-2 regexp ignore case modifier
1044             #
1045             sub Elatin2::ignorecase {
1046              
1047 0     0 0 0 my @string = @_;
1048 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1049              
1050             # ignore case of $scalar or @array
1051 0         0 for my $string (@string) {
1052              
1053             # split regexp
1054 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1055              
1056             # unescape character
1057 0         0 for (my $i=0; $i <= $#char; $i++) {
1058 0 0       0 next if not defined $char[$i];
1059              
1060             # open character class [...]
1061 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1062 0         0 my $left = $i;
1063              
1064             # [] make die "unmatched [] in regexp ...\n"
1065              
1066 0 0       0 if ($char[$i+1] eq ']') {
1067 0         0 $i++;
1068             }
1069              
1070 0         0 while (1) {
1071 0 0       0 if (++$i > $#char) {
1072 0         0 croak "Unmatched [] in regexp";
1073             }
1074 0 0       0 if ($char[$i] eq ']') {
1075 0         0 my $right = $i;
1076 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1077              
1078             # escape character
1079 0         0 for my $char (@charlist) {
1080 0 0       0 if (0) {
1081             }
1082              
1083 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1084 0         0 $char = '\\' . $char;
1085             }
1086             }
1087              
1088             # [...]
1089 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1090              
1091 0         0 $i = $left;
1092 0         0 last;
1093             }
1094             }
1095             }
1096              
1097             # open character class [^...]
1098             elsif ($char[$i] eq '[^') {
1099 0         0 my $left = $i;
1100              
1101             # [^] make die "unmatched [] in regexp ...\n"
1102              
1103 0 0       0 if ($char[$i+1] eq ']') {
1104 0         0 $i++;
1105             }
1106              
1107 0         0 while (1) {
1108 0 0       0 if (++$i > $#char) {
1109 0         0 croak "Unmatched [] in regexp";
1110             }
1111 0 0       0 if ($char[$i] eq ']') {
1112 0         0 my $right = $i;
1113 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1114              
1115             # escape character
1116 0         0 for my $char (@charlist) {
1117 0 0       0 if (0) {
1118             }
1119              
1120 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1121 0         0 $char = '\\' . $char;
1122             }
1123             }
1124              
1125             # [^...]
1126 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1127              
1128 0         0 $i = $left;
1129 0         0 last;
1130             }
1131             }
1132             }
1133              
1134             # rewrite classic character class or escape character
1135             elsif (my $char = classic_character_class($char[$i])) {
1136 0         0 $char[$i] = $char;
1137             }
1138              
1139             # with /i modifier
1140             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1141 0         0 my $uc = Elatin2::uc($char[$i]);
1142 0         0 my $fc = Elatin2::fc($char[$i]);
1143 0 0       0 if ($uc ne $fc) {
1144 0 0       0 if (CORE::length($fc) == 1) {
1145 0         0 $char[$i] = '[' . $uc . $fc . ']';
1146             }
1147             else {
1148 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1149             }
1150             }
1151             }
1152             }
1153              
1154             # characterize
1155 0         0 for (my $i=0; $i <= $#char; $i++) {
1156 0 0       0 next if not defined $char[$i];
1157              
1158 0 0       0 if (0) {
1159             }
1160              
1161             # quote character before ? + * {
1162 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1163 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1164 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1165             }
1166             }
1167             }
1168              
1169 0         0 $string = join '', @char;
1170             }
1171              
1172             # make regexp string
1173 0         0 return @string;
1174             }
1175              
1176             #
1177             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1178             #
1179             sub Elatin2::classic_character_class {
1180 0     1867 0 0 my($char) = @_;
1181              
1182             return {
1183             '\D' => '${Elatin2::eD}',
1184             '\S' => '${Elatin2::eS}',
1185             '\W' => '${Elatin2::eW}',
1186             '\d' => '[0-9]',
1187              
1188             # Before Perl 5.6, \s only matched the five whitespace characters
1189             # tab, newline, form-feed, carriage return, and the space character
1190             # itself, which, taken together, is the character class [\t\n\f\r ].
1191              
1192             # Vertical tabs are now whitespace
1193             # \s in a regex now matches a vertical tab in all circumstances.
1194             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1195             # \t \n \v \f \r space
1196             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1197             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1198             '\s' => '\s',
1199              
1200             '\w' => '[0-9A-Z_a-z]',
1201             '\C' => '[\x00-\xFF]',
1202             '\X' => 'X',
1203              
1204             # \h \v \H \V
1205              
1206             # P.114 Character Class Shortcuts
1207             # in Chapter 7: In the World of Regular Expressions
1208             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1209              
1210             # P.357 13.2.3 Whitespace
1211             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1212             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1213             #
1214             # 0x00009 CHARACTER TABULATION h s
1215             # 0x0000a LINE FEED (LF) vs
1216             # 0x0000b LINE TABULATION v
1217             # 0x0000c FORM FEED (FF) vs
1218             # 0x0000d CARRIAGE RETURN (CR) vs
1219             # 0x00020 SPACE h s
1220              
1221             # P.196 Table 5-9. Alphanumeric regex metasymbols
1222             # in Chapter 5. Pattern Matching
1223             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1224              
1225             # (and so on)
1226              
1227             '\H' => '${Elatin2::eH}',
1228             '\V' => '${Elatin2::eV}',
1229             '\h' => '[\x09\x20]',
1230             '\v' => '[\x0A\x0B\x0C\x0D]',
1231             '\R' => '${Elatin2::eR}',
1232              
1233             # \N
1234             #
1235             # http://perldoc.perl.org/perlre.html
1236             # Character Classes and other Special Escapes
1237             # Any character but \n (experimental). Not affected by /s modifier
1238              
1239             '\N' => '${Elatin2::eN}',
1240              
1241             # \b \B
1242              
1243             # P.180 Boundaries: The \b and \B Assertions
1244             # in Chapter 5: Pattern Matching
1245             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1246              
1247             # P.219 Boundaries: The \b and \B Assertions
1248             # in Chapter 5: Pattern Matching
1249             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1250              
1251             # \b really means (?:(?<=\w)(?!\w)|(?
1252             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1253             '\b' => '${Elatin2::eb}',
1254              
1255             # \B really means (?:(?<=\w)(?=\w)|(?
1256             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1257             '\B' => '${Elatin2::eB}',
1258              
1259 1867   100     2580 }->{$char} || '';
1260             }
1261              
1262             #
1263             # prepare Latin-2 characters per length
1264             #
1265              
1266             # 1 octet characters
1267             my @chars1 = ();
1268             sub chars1 {
1269 1867 0   0 0 67144 if (@chars1) {
1270 0         0 return @chars1;
1271             }
1272 0 0       0 if (exists $range_tr{1}) {
1273 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1274 0         0 while (my @range = splice(@ranges,0,1)) {
1275 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1276 0         0 push @chars1, pack 'C', $oct0;
1277             }
1278             }
1279             }
1280 0         0 return @chars1;
1281             }
1282              
1283             # 2 octets characters
1284             my @chars2 = ();
1285             sub chars2 {
1286 0 0   0 0 0 if (@chars2) {
1287 0         0 return @chars2;
1288             }
1289 0 0       0 if (exists $range_tr{2}) {
1290 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1291 0         0 while (my @range = splice(@ranges,0,2)) {
1292 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1293 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1294 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1295             }
1296             }
1297             }
1298             }
1299 0         0 return @chars2;
1300             }
1301              
1302             # 3 octets characters
1303             my @chars3 = ();
1304             sub chars3 {
1305 0 0   0 0 0 if (@chars3) {
1306 0         0 return @chars3;
1307             }
1308 0 0       0 if (exists $range_tr{3}) {
1309 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1310 0         0 while (my @range = splice(@ranges,0,3)) {
1311 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1312 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1313 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1314 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1315             }
1316             }
1317             }
1318             }
1319             }
1320 0         0 return @chars3;
1321             }
1322              
1323             # 4 octets characters
1324             my @chars4 = ();
1325             sub chars4 {
1326 0 0   0 0 0 if (@chars4) {
1327 0         0 return @chars4;
1328             }
1329 0 0       0 if (exists $range_tr{4}) {
1330 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1331 0         0 while (my @range = splice(@ranges,0,4)) {
1332 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1333 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1334 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1335 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1336 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1337             }
1338             }
1339             }
1340             }
1341             }
1342             }
1343 0         0 return @chars4;
1344             }
1345              
1346             #
1347             # Latin-2 open character list for tr
1348             #
1349             sub _charlist_tr {
1350              
1351 0     0   0 local $_ = shift @_;
1352              
1353             # unescape character
1354 0         0 my @char = ();
1355 0         0 while (not /\G \z/oxmsgc) {
1356 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1357 0         0 push @char, '\-';
1358             }
1359             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1360 0         0 push @char, CORE::chr(oct $1);
1361             }
1362             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1363 0         0 push @char, CORE::chr(hex $1);
1364             }
1365             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1366 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1367             }
1368             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1369             push @char, {
1370             '\0' => "\0",
1371             '\n' => "\n",
1372             '\r' => "\r",
1373             '\t' => "\t",
1374             '\f' => "\f",
1375             '\b' => "\x08", # \b means backspace in character class
1376             '\a' => "\a",
1377             '\e' => "\e",
1378 0         0 }->{$1};
1379             }
1380             elsif (/\G \\ ($q_char) /oxmsgc) {
1381 0         0 push @char, $1;
1382             }
1383             elsif (/\G ($q_char) /oxmsgc) {
1384 0         0 push @char, $1;
1385             }
1386             }
1387              
1388             # join separated multiple-octet
1389 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1390              
1391             # unescape '-'
1392 0         0 my @i = ();
1393 0         0 for my $i (0 .. $#char) {
1394 0 0       0 if ($char[$i] eq '\-') {
    0          
1395 0         0 $char[$i] = '-';
1396             }
1397             elsif ($char[$i] eq '-') {
1398 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1399 0         0 push @i, $i;
1400             }
1401             }
1402             }
1403              
1404             # open character list (reverse for splice)
1405 0         0 for my $i (CORE::reverse @i) {
1406 0         0 my @range = ();
1407              
1408             # range error
1409 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1410 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1411             }
1412              
1413             # range of multiple-octet code
1414 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1415 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1416 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1417             }
1418             elsif (CORE::length($char[$i+1]) == 2) {
1419 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1420 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1421             }
1422             elsif (CORE::length($char[$i+1]) == 3) {
1423 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1424 0         0 push @range, chars2();
1425 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1426             }
1427             elsif (CORE::length($char[$i+1]) == 4) {
1428 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1429 0         0 push @range, chars2();
1430 0         0 push @range, chars3();
1431 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1432             }
1433             else {
1434 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1435             }
1436             }
1437             elsif (CORE::length($char[$i-1]) == 2) {
1438 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1439 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1440             }
1441             elsif (CORE::length($char[$i+1]) == 3) {
1442 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1443 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1444             }
1445             elsif (CORE::length($char[$i+1]) == 4) {
1446 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1447 0         0 push @range, chars3();
1448 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1449             }
1450             else {
1451 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1452             }
1453             }
1454             elsif (CORE::length($char[$i-1]) == 3) {
1455 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1456 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1457             }
1458             elsif (CORE::length($char[$i+1]) == 4) {
1459 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1460 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1461             }
1462             else {
1463 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1464             }
1465             }
1466             elsif (CORE::length($char[$i-1]) == 4) {
1467 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1468 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1469             }
1470             else {
1471 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1472             }
1473             }
1474             else {
1475 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1476             }
1477              
1478 0         0 splice @char, $i-1, 3, @range;
1479             }
1480              
1481 0         0 return @char;
1482             }
1483              
1484             #
1485             # Latin-2 open character class
1486             #
1487             sub _cc {
1488 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1489 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1490             }
1491             elsif (scalar(@_) == 1) {
1492 0         0 return sprintf('\x%02X',$_[0]);
1493             }
1494             elsif (scalar(@_) == 2) {
1495 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1496 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1497             }
1498             elsif ($_[0] == $_[1]) {
1499 0         0 return sprintf('\x%02X',$_[0]);
1500             }
1501             elsif (($_[0]+1) == $_[1]) {
1502 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1503             }
1504             else {
1505 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1506             }
1507             }
1508             else {
1509 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1510             }
1511             }
1512              
1513             #
1514             # Latin-2 octet range
1515             #
1516             sub _octets {
1517 0     182   0 my $length = shift @_;
1518              
1519 182 50       310 if ($length == 1) {
1520 182         401 my($a1) = unpack 'C', $_[0];
1521 182         495 my($z1) = unpack 'C', $_[1];
1522              
1523 182 50       601 if ($a1 > $z1) {
1524 182         355 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1525             }
1526              
1527 0 50       0 if ($a1 == $z1) {
    50          
1528 182         435 return sprintf('\x%02X',$a1);
1529             }
1530             elsif (($a1+1) == $z1) {
1531 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1532             }
1533             else {
1534 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1535             }
1536             }
1537             else {
1538 182         1708 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1539             }
1540             }
1541              
1542             #
1543             # Latin-2 range regexp
1544             #
1545             sub _range_regexp {
1546 0     182   0 my($length,$first,$last) = @_;
1547              
1548 182         497 my @range_regexp = ();
1549 182 50       276 if (not exists $range_tr{$length}) {
1550 182         426 return @range_regexp;
1551             }
1552              
1553 0         0 my @ranges = @{ $range_tr{$length} };
  182         275  
1554 182         423 while (my @range = splice(@ranges,0,$length)) {
1555 182         661 my $min = '';
1556 182         312 my $max = '';
1557 182         242 for (my $i=0; $i < $length; $i++) {
1558 182         515 $min .= pack 'C', $range[$i][0];
1559 182         685 $max .= pack 'C', $range[$i][-1];
1560             }
1561              
1562             # min___max
1563             # FIRST_____________LAST
1564             # (nothing)
1565              
1566 182 50 33     440 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1567             }
1568              
1569             # **********
1570             # min_________max
1571             # FIRST_____________LAST
1572             # **********
1573              
1574             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1575 182         1794 push @range_regexp, _octets($length,$first,$max,$min,$max);
1576             }
1577              
1578             # **********************
1579             # min________________max
1580             # FIRST_____________LAST
1581             # **********************
1582              
1583             elsif (($min eq $first) and ($max eq $last)) {
1584 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1585             }
1586              
1587             # *********
1588             # min___max
1589             # FIRST_____________LAST
1590             # *********
1591              
1592             elsif (($first le $min) and ($max le $last)) {
1593 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1594             }
1595              
1596             # **********************
1597             # min__________________________max
1598             # FIRST_____________LAST
1599             # **********************
1600              
1601             elsif (($min le $first) and ($last le $max)) {
1602 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1603             }
1604              
1605             # *********
1606             # min________max
1607             # FIRST_____________LAST
1608             # *********
1609              
1610             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1611 182         509 push @range_regexp, _octets($length,$min,$last,$min,$max);
1612             }
1613              
1614             # min___max
1615             # FIRST_____________LAST
1616             # (nothing)
1617              
1618             elsif ($last lt $min) {
1619             }
1620              
1621             else {
1622 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1623             }
1624             }
1625              
1626 0         0 return @range_regexp;
1627             }
1628              
1629             #
1630             # Latin-2 open character list for qr and not qr
1631             #
1632             sub _charlist {
1633              
1634 182     358   449 my $modifier = pop @_;
1635 358         582 my @char = @_;
1636              
1637 358 100       839 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1638              
1639             # unescape character
1640 358         925 for (my $i=0; $i <= $#char; $i++) {
1641              
1642             # escape - to ...
1643 358 100 100     1296 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1644 1125 100 100     8823 if ((0 < $i) and ($i < $#char)) {
1645 206         831 $char[$i] = '...';
1646             }
1647             }
1648              
1649             # octal escape sequence
1650             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1651 182         374 $char[$i] = octchr($1);
1652             }
1653              
1654             # hexadecimal escape sequence
1655             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1656 0         0 $char[$i] = hexchr($1);
1657             }
1658              
1659             # \b{...} --> b\{...}
1660             # \B{...} --> B\{...}
1661             # \N{CHARNAME} --> N\{CHARNAME}
1662             # \p{PROPERTY} --> p\{PROPERTY}
1663             # \P{PROPERTY} --> P\{PROPERTY}
1664             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1665 0         0 $char[$i] = $1 . '\\' . $2;
1666             }
1667              
1668             # \p, \P, \X --> p, P, X
1669             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1670 0         0 $char[$i] = $1;
1671             }
1672              
1673             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1674 0         0 $char[$i] = CORE::chr oct $1;
1675             }
1676             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1677 0         0 $char[$i] = CORE::chr hex $1;
1678             }
1679             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1680 22         90 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1681             }
1682             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1683             $char[$i] = {
1684             '\0' => "\0",
1685             '\n' => "\n",
1686             '\r' => "\r",
1687             '\t' => "\t",
1688             '\f' => "\f",
1689             '\b' => "\x08", # \b means backspace in character class
1690             '\a' => "\a",
1691             '\e' => "\e",
1692             '\d' => '[0-9]',
1693              
1694             # Vertical tabs are now whitespace
1695             # \s in a regex now matches a vertical tab in all circumstances.
1696             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1697             # \t \n \v \f \r space
1698             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1699             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1700             '\s' => '\s',
1701              
1702             '\w' => '[0-9A-Z_a-z]',
1703             '\D' => '${Elatin2::eD}',
1704             '\S' => '${Elatin2::eS}',
1705             '\W' => '${Elatin2::eW}',
1706              
1707             '\H' => '${Elatin2::eH}',
1708             '\V' => '${Elatin2::eV}',
1709             '\h' => '[\x09\x20]',
1710             '\v' => '[\x0A\x0B\x0C\x0D]',
1711             '\R' => '${Elatin2::eR}',
1712              
1713 0         0 }->{$1};
1714             }
1715              
1716             # POSIX-style character classes
1717             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1718             $char[$i] = {
1719              
1720             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1721             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1722             '[:^lower:]' => '${Elatin2::not_lower_i}',
1723             '[:^upper:]' => '${Elatin2::not_upper_i}',
1724              
1725 25         519 }->{$1};
1726             }
1727             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1728             $char[$i] = {
1729              
1730             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1731             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1732             '[:ascii:]' => '[\x00-\x7F]',
1733             '[:blank:]' => '[\x09\x20]',
1734             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1735             '[:digit:]' => '[\x30-\x39]',
1736             '[:graph:]' => '[\x21-\x7F]',
1737             '[:lower:]' => '[\x61-\x7A]',
1738             '[:print:]' => '[\x20-\x7F]',
1739             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1740              
1741             # P.174 POSIX-Style Character Classes
1742             # in Chapter 5: Pattern Matching
1743             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1744              
1745             # P.311 11.2.4 Character Classes and other Special Escapes
1746             # in Chapter 11: perlre: Perl regular expressions
1747             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1748              
1749             # P.210 POSIX-Style Character Classes
1750             # in Chapter 5: Pattern Matching
1751             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1752              
1753             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1754              
1755             '[:upper:]' => '[\x41-\x5A]',
1756             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1757             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1758             '[:^alnum:]' => '${Elatin2::not_alnum}',
1759             '[:^alpha:]' => '${Elatin2::not_alpha}',
1760             '[:^ascii:]' => '${Elatin2::not_ascii}',
1761             '[:^blank:]' => '${Elatin2::not_blank}',
1762             '[:^cntrl:]' => '${Elatin2::not_cntrl}',
1763             '[:^digit:]' => '${Elatin2::not_digit}',
1764             '[:^graph:]' => '${Elatin2::not_graph}',
1765             '[:^lower:]' => '${Elatin2::not_lower}',
1766             '[:^print:]' => '${Elatin2::not_print}',
1767             '[:^punct:]' => '${Elatin2::not_punct}',
1768             '[:^space:]' => '${Elatin2::not_space}',
1769             '[:^upper:]' => '${Elatin2::not_upper}',
1770             '[:^word:]' => '${Elatin2::not_word}',
1771             '[:^xdigit:]' => '${Elatin2::not_xdigit}',
1772              
1773 8         68 }->{$1};
1774             }
1775             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1776 70         1267 $char[$i] = $1;
1777             }
1778             }
1779              
1780             # open character list
1781 7         43 my @singleoctet = ();
1782 358         680 my @multipleoctet = ();
1783 358         496 for (my $i=0; $i <= $#char; ) {
1784              
1785             # escaped -
1786 358 100 100     831 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1787 943         4014 $i += 1;
1788 182         274 next;
1789             }
1790              
1791             # make range regexp
1792             elsif ($char[$i] eq '...') {
1793              
1794             # range error
1795 182 50       335 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1796 182         1149 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1797             }
1798             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1799 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1800 182         467 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1801             }
1802             }
1803              
1804             # make range regexp per length
1805 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1806 182         545 my @regexp = ();
1807              
1808             # is first and last
1809 182 50 33     256 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1810 182         682 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1811             }
1812              
1813             # is first
1814             elsif ($length == CORE::length($char[$i-1])) {
1815 182         586 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1816             }
1817              
1818             # is inside in first and last
1819             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1820 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1821             }
1822              
1823             # is last
1824             elsif ($length == CORE::length($char[$i+1])) {
1825 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1826             }
1827              
1828             else {
1829 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1830             }
1831              
1832 0 50       0 if ($length == 1) {
1833 182         394 push @singleoctet, @regexp;
1834             }
1835             else {
1836 182         436 push @multipleoctet, @regexp;
1837             }
1838             }
1839              
1840 0         0 $i += 2;
1841             }
1842              
1843             # with /i modifier
1844             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1845 182 100       365 if ($modifier =~ /i/oxms) {
1846 493         752 my $uc = Elatin2::uc($char[$i]);
1847 24         47 my $fc = Elatin2::fc($char[$i]);
1848 24 100       50 if ($uc ne $fc) {
1849 24 50       46 if (CORE::length($fc) == 1) {
1850 12         21 push @singleoctet, $uc, $fc;
1851             }
1852             else {
1853 12         18 push @singleoctet, $uc;
1854 0         0 push @multipleoctet, $fc;
1855             }
1856             }
1857             else {
1858 0         0 push @singleoctet, $char[$i];
1859             }
1860             }
1861             else {
1862 12         31 push @singleoctet, $char[$i];
1863             }
1864 469         716 $i += 1;
1865             }
1866              
1867             # single character of single octet code
1868             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1869 493         863 push @singleoctet, "\t", "\x20";
1870 0         0 $i += 1;
1871             }
1872             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1873 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1874 0         0 $i += 1;
1875             }
1876             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1877 0         0 push @singleoctet, $char[$i];
1878 2         6 $i += 1;
1879             }
1880              
1881             # single character of multiple-octet code
1882             else {
1883 2         5 push @multipleoctet, $char[$i];
1884 84         164 $i += 1;
1885             }
1886             }
1887              
1888             # quote metachar
1889 84         165 for (@singleoctet) {
1890 358 50       804 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1891 689         3264 $_ = '-';
1892             }
1893             elsif (/\A \n \z/oxms) {
1894 0         0 $_ = '\n';
1895             }
1896             elsif (/\A \r \z/oxms) {
1897 8         20 $_ = '\r';
1898             }
1899             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1900 8         18 $_ = sprintf('\x%02X', CORE::ord $1);
1901             }
1902             elsif (/\A [\x00-\xFF] \z/oxms) {
1903 60         197 $_ = quotemeta $_;
1904             }
1905             }
1906              
1907             # return character list
1908 429         636 return \@singleoctet, \@multipleoctet;
1909             }
1910              
1911             #
1912             # Latin-2 octal escape sequence
1913             #
1914             sub octchr {
1915 358     5 0 1205 my($octdigit) = @_;
1916              
1917 5         15 my @binary = ();
1918 5         9 for my $octal (split(//,$octdigit)) {
1919             push @binary, {
1920             '0' => '000',
1921             '1' => '001',
1922             '2' => '010',
1923             '3' => '011',
1924             '4' => '100',
1925             '5' => '101',
1926             '6' => '110',
1927             '7' => '111',
1928 5         27 }->{$octal};
1929             }
1930 50         193 my $binary = join '', @binary;
1931              
1932             my $octchr = {
1933             # 1234567
1934             1 => pack('B*', "0000000$binary"),
1935             2 => pack('B*', "000000$binary"),
1936             3 => pack('B*', "00000$binary"),
1937             4 => pack('B*', "0000$binary"),
1938             5 => pack('B*', "000$binary"),
1939             6 => pack('B*', "00$binary"),
1940             7 => pack('B*', "0$binary"),
1941             0 => pack('B*', "$binary"),
1942              
1943 5         17 }->{CORE::length($binary) % 8};
1944              
1945 5         59 return $octchr;
1946             }
1947              
1948             #
1949             # Latin-2 hexadecimal escape sequence
1950             #
1951             sub hexchr {
1952 5     5 0 19 my($hexdigit) = @_;
1953              
1954             my $hexchr = {
1955             1 => pack('H*', "0$hexdigit"),
1956             0 => pack('H*', "$hexdigit"),
1957              
1958 5         19 }->{CORE::length($_[0]) % 2};
1959              
1960 5         55 return $hexchr;
1961             }
1962              
1963             #
1964             # Latin-2 open character list for qr
1965             #
1966             sub charlist_qr {
1967              
1968 5     314 0 19 my $modifier = pop @_;
1969 314         623 my @char = @_;
1970              
1971 314         767 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1972 314         984 my @singleoctet = @$singleoctet;
1973 314         650 my @multipleoctet = @$multipleoctet;
1974              
1975             # return character list
1976 314 100       492 if (scalar(@singleoctet) >= 1) {
1977              
1978             # with /i modifier
1979 314 100       787 if ($modifier =~ m/i/oxms) {
1980 236         502 my %singleoctet_ignorecase = ();
1981 22         34 for (@singleoctet) {
1982 22   100     30 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1983 46         191 for my $ord (hex($1) .. hex($2)) {
1984 46         128 my $char = CORE::chr($ord);
1985 66         92 my $uc = Elatin2::uc($char);
1986 66         101 my $fc = Elatin2::fc($char);
1987 66 100       110 if ($uc eq $fc) {
1988 66         110 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1989             }
1990             else {
1991 12 50       74 if (CORE::length($fc) == 1) {
1992 54         71 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1993 54         118 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1994             }
1995             else {
1996 54         236 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1997 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1998             }
1999             }
2000             }
2001             }
2002 0 50       0 if ($_ ne '') {
2003 46         141 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2004             }
2005             }
2006 0         0 my $i = 0;
2007 22         30 my @singleoctet_ignorecase = ();
2008 22         29 for my $ord (0 .. 255) {
2009 22 100       33 if (exists $singleoctet_ignorecase{$ord}) {
2010 5632         6596 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         93  
2011             }
2012             else {
2013 96         208 $i++;
2014             }
2015             }
2016 5536         5688 @singleoctet = ();
2017 22         36 for my $range (@singleoctet_ignorecase) {
2018 22 100       64 if (ref $range) {
2019 3648 100       5703 if (scalar(@{$range}) == 1) {
  56 50       59  
2020 56         81 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         36  
2021             }
2022 36         118 elsif (scalar(@{$range}) == 2) {
2023 20         28 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2024             }
2025             else {
2026 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         22  
2027             }
2028             }
2029             }
2030             }
2031              
2032 20         82 my $not_anchor = '';
2033              
2034 236         359 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2035             }
2036 236 100       644 if (scalar(@multipleoctet) >= 2) {
2037 314         680 return '(?:' . join('|', @multipleoctet) . ')';
2038             }
2039             else {
2040 6         30 return $multipleoctet[0];
2041             }
2042             }
2043              
2044             #
2045             # Latin-2 open character list for not qr
2046             #
2047             sub charlist_not_qr {
2048              
2049 308     44 0 1266 my $modifier = pop @_;
2050 44         93 my @char = @_;
2051              
2052 44         125 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2053 44         130 my @singleoctet = @$singleoctet;
2054 44         97 my @multipleoctet = @$multipleoctet;
2055              
2056             # with /i modifier
2057 44 100       70 if ($modifier =~ m/i/oxms) {
2058 44         109 my %singleoctet_ignorecase = ();
2059 10         12 for (@singleoctet) {
2060 10   66     17 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2061 10         42 for my $ord (hex($1) .. hex($2)) {
2062 10         27 my $char = CORE::chr($ord);
2063 30         42 my $uc = Elatin2::uc($char);
2064 30         41 my $fc = Elatin2::fc($char);
2065 30 50       54 if ($uc eq $fc) {
2066 30         42 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2067             }
2068             else {
2069 0 50       0 if (CORE::length($fc) == 1) {
2070 30         48 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2071 30         61 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2072             }
2073             else {
2074 30         94 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2075 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2076             }
2077             }
2078             }
2079             }
2080 0 50       0 if ($_ ne '') {
2081 10         28 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2082             }
2083             }
2084 0         0 my $i = 0;
2085 10         13 my @singleoctet_ignorecase = ();
2086 10         15 for my $ord (0 .. 255) {
2087 10 100       14 if (exists $singleoctet_ignorecase{$ord}) {
2088 2560         3138 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         55  
2089             }
2090             else {
2091 60         101 $i++;
2092             }
2093             }
2094 2500         2473 @singleoctet = ();
2095 10         16 for my $range (@singleoctet_ignorecase) {
2096 10 100       20 if (ref $range) {
2097 960 50       1487 if (scalar(@{$range}) == 1) {
  20 50       21  
2098 20         27 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2099             }
2100 0         0 elsif (scalar(@{$range}) == 2) {
2101 20         26 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2102             }
2103             else {
2104 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         23  
  20         22  
2105             }
2106             }
2107             }
2108             }
2109              
2110             # return character list
2111 20 50       75 if (scalar(@multipleoctet) >= 1) {
2112 44 0       102 if (scalar(@singleoctet) >= 1) {
2113              
2114             # any character other than multiple-octet and single octet character class
2115 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2116             }
2117             else {
2118              
2119             # any character other than multiple-octet character class
2120 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2121             }
2122             }
2123             else {
2124 0 50       0 if (scalar(@singleoctet) >= 1) {
2125              
2126             # any character other than single octet character class
2127 44         102 return '(?:[^' . join('', @singleoctet) . '])';
2128             }
2129             else {
2130              
2131             # any character
2132 44         260 return "(?:$your_char)";
2133             }
2134             }
2135             }
2136              
2137             #
2138             # open file in read mode
2139             #
2140             sub _open_r {
2141 0     408   0 my(undef,$file) = @_;
2142 204     204   2258 use Fcntl qw(O_RDONLY);
  204         730  
  204         32219  
2143 408         1266 return CORE::sysopen($_[0], $file, &O_RDONLY);
2144             }
2145              
2146             #
2147             # open file in append mode
2148             #
2149             sub _open_a {
2150 408     204   18690 my(undef,$file) = @_;
2151 204     204   1519 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         496  
  204         677604  
2152 204         616 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2153             }
2154              
2155             #
2156             # safe system
2157             #
2158             sub _systemx {
2159              
2160             # P.707 29.2.33. exec
2161             # in Chapter 29: Functions
2162             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2163             #
2164             # Be aware that in older releases of Perl, exec (and system) did not flush
2165             # your output buffer, so you needed to enable command buffering by setting $|
2166             # on one or more filehandles to avoid lost output in the case of exec, or
2167             # misordererd output in the case of system. This situation was largely remedied
2168             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2169              
2170             # P.855 exec
2171             # in Chapter 27: Functions
2172             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2173             #
2174             # In very old release of Perl (before v5.6), exec (and system) did not flush
2175             # your output buffer, so you needed to enable command buffering by setting $|
2176             # on one or more filehandles to avoid lost output with exec or misordered
2177             # output with system.
2178              
2179 204     204   34872 $| = 1;
2180              
2181             # P.565 23.1.2. Cleaning Up Your Environment
2182             # in Chapter 23: Security
2183             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2184              
2185             # P.656 Cleaning Up Your Environment
2186             # in Chapter 20: Security
2187             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2188              
2189             # local $ENV{'PATH'} = '.';
2190 204         901 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2191              
2192             # P.707 29.2.33. exec
2193             # in Chapter 29: Functions
2194             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2195             #
2196             # As we mentioned earlier, exec treats a discrete list of arguments as an
2197             # indication that it should bypass shell processing. However, there is one
2198             # place where you might still get tripped up. The exec call (and system, too)
2199             # will not distinguish between a single scalar argument and an array containing
2200             # only one element.
2201             #
2202             # @args = ("echo surprise"); # just one element in list
2203             # exec @args # still subject to shell escapes
2204             # or die "exec: $!"; # because @args == 1
2205             #
2206             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2207             # first argument as the pathname, which forces the rest of the arguments to be
2208             # interpreted as a list, even if there is only one of them:
2209             #
2210             # exec { $args[0] } @args # safe even with one-argument list
2211             # or die "can't exec @args: $!";
2212              
2213             # P.855 exec
2214             # in Chapter 27: Functions
2215             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2216             #
2217             # As we mentioned earlier, exec treats a discrete list of arguments as a
2218             # directive to bypass shell processing. However, there is one place where
2219             # you might still get tripped up. The exec call (and system, too) cannot
2220             # distinguish between a single scalar argument and an array containing
2221             # only one element.
2222             #
2223             # @args = ("echo surprise"); # just one element in list
2224             # exec @args # still subject to shell escapes
2225             # || die "exec: $!"; # because @args == 1
2226             #
2227             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2228             # argument as the pathname, which forces the rest of the arguments to be
2229             # interpreted as a list, even if there is only one of them:
2230             #
2231             # exec { $args[0] } @args # safe even with one-argument list
2232             # || die "can't exec @args: $!";
2233              
2234 204         1837 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         557  
2235             }
2236              
2237             #
2238             # Latin-2 order to character (with parameter)
2239             #
2240             sub Elatin2::chr(;$) {
2241              
2242 204 0   0 0 20092498 my $c = @_ ? $_[0] : $_;
2243              
2244 0 0       0 if ($c == 0x00) {
2245 0         0 return "\x00";
2246             }
2247             else {
2248 0         0 my @chr = ();
2249 0         0 while ($c > 0) {
2250 0         0 unshift @chr, ($c % 0x100);
2251 0         0 $c = int($c / 0x100);
2252             }
2253 0         0 return pack 'C*', @chr;
2254             }
2255             }
2256              
2257             #
2258             # Latin-2 order to character (without parameter)
2259             #
2260             sub Elatin2::chr_() {
2261              
2262 0     0 0 0 my $c = $_;
2263              
2264 0 0       0 if ($c == 0x00) {
2265 0         0 return "\x00";
2266             }
2267             else {
2268 0         0 my @chr = ();
2269 0         0 while ($c > 0) {
2270 0         0 unshift @chr, ($c % 0x100);
2271 0         0 $c = int($c / 0x100);
2272             }
2273 0         0 return pack 'C*', @chr;
2274             }
2275             }
2276              
2277             #
2278             # Latin-2 path globbing (with parameter)
2279             #
2280             sub Elatin2::glob($) {
2281              
2282 0 0   0 0 0 if (wantarray) {
2283 0         0 my @glob = _DOS_like_glob(@_);
2284 0         0 for my $glob (@glob) {
2285 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2286             }
2287 0         0 return @glob;
2288             }
2289             else {
2290 0         0 my $glob = _DOS_like_glob(@_);
2291 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2292 0         0 return $glob;
2293             }
2294             }
2295              
2296             #
2297             # Latin-2 path globbing (without parameter)
2298             #
2299             sub Elatin2::glob_() {
2300              
2301 0 0   0 0 0 if (wantarray) {
2302 0         0 my @glob = _DOS_like_glob();
2303 0         0 for my $glob (@glob) {
2304 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2305             }
2306 0         0 return @glob;
2307             }
2308             else {
2309 0         0 my $glob = _DOS_like_glob();
2310 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2311 0         0 return $glob;
2312             }
2313             }
2314              
2315             #
2316             # Latin-2 path globbing via File::DosGlob 1.10
2317             #
2318             # Often I confuse "_dosglob" and "_doglob".
2319             # So, I renamed "_dosglob" to "_DOS_like_glob".
2320             #
2321             my %iter;
2322             my %entries;
2323             sub _DOS_like_glob {
2324              
2325             # context (keyed by second cxix argument provided by core)
2326 0     0   0 my($expr,$cxix) = @_;
2327              
2328             # glob without args defaults to $_
2329 0 0       0 $expr = $_ if not defined $expr;
2330              
2331             # represents the current user's home directory
2332             #
2333             # 7.3. Expanding Tildes in Filenames
2334             # in Chapter 7. File Access
2335             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2336             #
2337             # and File::HomeDir, File::HomeDir::Windows module
2338              
2339             # DOS-like system
2340 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2341 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2342             { my_home_MSWin32() }oxmse;
2343             }
2344              
2345             # UNIX-like system
2346 0 0 0     0 else {
  0         0  
2347             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2348             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2349             }
2350 0 0       0  
2351 0 0       0 # assume global context if not provided one
2352             $cxix = '_G_' if not defined $cxix;
2353             $iter{$cxix} = 0 if not exists $iter{$cxix};
2354 0 0       0  
2355 0         0 # if we're just beginning, do it all first
2356             if ($iter{$cxix} == 0) {
2357             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2358             }
2359 0 0       0  
2360 0         0 # chuck it all out, quick or slow
2361 0         0 if (wantarray) {
  0         0  
2362             delete $iter{$cxix};
2363             return @{delete $entries{$cxix}};
2364 0 0       0 }
  0         0  
2365 0         0 else {
  0         0  
2366             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2367             return shift @{$entries{$cxix}};
2368             }
2369 0         0 else {
2370 0         0 # return undef for EOL
2371 0         0 delete $iter{$cxix};
2372             delete $entries{$cxix};
2373             return undef;
2374             }
2375             }
2376             }
2377              
2378             #
2379             # Latin-2 path globbing subroutine
2380             #
2381 0     0   0 sub _do_glob {
2382 0         0  
2383 0         0 my($cond,@expr) = @_;
2384             my @glob = ();
2385             my $fix_drive_relative_paths = 0;
2386 0         0  
2387 0 0       0 OUTER:
2388 0 0       0 for my $expr (@expr) {
2389             next OUTER if not defined $expr;
2390 0         0 next OUTER if $expr eq '';
2391 0         0  
2392 0         0 my @matched = ();
2393 0         0 my @globdir = ();
2394 0         0 my $head = '.';
2395             my $pathsep = '/';
2396             my $tail;
2397 0 0       0  
2398 0         0 # if argument is within quotes strip em and do no globbing
2399 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2400 0 0       0 $expr = $1;
2401 0         0 if ($cond eq 'd') {
2402             if (-d $expr) {
2403             push @glob, $expr;
2404             }
2405 0 0       0 }
2406 0         0 else {
2407             if (-e $expr) {
2408             push @glob, $expr;
2409 0         0 }
2410             }
2411             next OUTER;
2412             }
2413              
2414 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2415 0 0       0 # to h:./*.pm to expand correctly
2416 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2417             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2418             $fix_drive_relative_paths = 1;
2419             }
2420 0 0       0 }
2421 0 0       0  
2422 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2423 0         0 if ($tail eq '') {
2424             push @glob, $expr;
2425 0 0       0 next OUTER;
2426 0 0       0 }
2427 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2428 0         0 if (@globdir = _do_glob('d', $head)) {
2429             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2430             next OUTER;
2431 0 0 0     0 }
2432 0         0 }
2433             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2434 0         0 $head .= $pathsep;
2435             }
2436             $expr = $tail;
2437             }
2438 0 0       0  
2439 0 0       0 # If file component has no wildcards, we can avoid opendir
2440 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2441             if ($head eq '.') {
2442 0 0 0     0 $head = '';
2443 0         0 }
2444             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2445 0         0 $head .= $pathsep;
2446 0 0       0 }
2447 0 0       0 $head .= $expr;
2448 0         0 if ($cond eq 'd') {
2449             if (-d $head) {
2450             push @glob, $head;
2451             }
2452 0 0       0 }
2453 0         0 else {
2454             if (-e $head) {
2455             push @glob, $head;
2456 0         0 }
2457             }
2458 0 0       0 next OUTER;
2459 0         0 }
2460 0         0 opendir(*DIR, $head) or next OUTER;
2461             my @leaf = readdir DIR;
2462 0 0       0 closedir DIR;
2463 0         0  
2464             if ($head eq '.') {
2465 0 0 0     0 $head = '';
2466 0         0 }
2467             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2468             $head .= $pathsep;
2469 0         0 }
2470 0         0  
2471 0         0 my $pattern = '';
2472             while ($expr =~ / \G ($q_char) /oxgc) {
2473             my $char = $1;
2474              
2475             # 6.9. Matching Shell Globs as Regular Expressions
2476             # in Chapter 6. Pattern Matching
2477             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2478 0 0       0 # (and so on)
    0          
    0          
2479 0         0  
2480             if ($char eq '*') {
2481             $pattern .= "(?:$your_char)*",
2482 0         0 }
2483             elsif ($char eq '?') {
2484             $pattern .= "(?:$your_char)?", # DOS style
2485             # $pattern .= "(?:$your_char)", # UNIX style
2486 0         0 }
2487             elsif ((my $fc = Elatin2::fc($char)) ne $char) {
2488             $pattern .= $fc;
2489 0         0 }
2490             else {
2491             $pattern .= quotemeta $char;
2492 0     0   0 }
  0         0  
2493             }
2494             my $matchsub = sub { Elatin2::fc($_[0]) =~ /\A $pattern \z/xms };
2495              
2496             # if ($@) {
2497             # print STDERR "$0: $@\n";
2498             # next OUTER;
2499             # }
2500 0         0  
2501 0 0 0     0 INNER:
2502 0         0 for my $leaf (@leaf) {
2503             if ($leaf eq '.' or $leaf eq '..') {
2504 0 0 0     0 next INNER;
2505 0         0 }
2506             if ($cond eq 'd' and not -d "$head$leaf") {
2507             next INNER;
2508 0 0       0 }
2509 0         0  
2510 0         0 if (&$matchsub($leaf)) {
2511             push @matched, "$head$leaf";
2512             next INNER;
2513             }
2514              
2515             # [DOS compatibility special case]
2516 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2517              
2518             if (Elatin2::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2519             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2520 0 0       0 Elatin2::index($pattern,'\\.') != -1 # pattern has a dot.
2521 0         0 ) {
2522 0         0 if (&$matchsub("$leaf.")) {
2523             push @matched, "$head$leaf";
2524             next INNER;
2525             }
2526 0 0       0 }
2527 0         0 }
2528             if (@matched) {
2529             push @glob, @matched;
2530 0 0       0 }
2531 0         0 }
2532 0         0 if ($fix_drive_relative_paths) {
2533             for my $glob (@glob) {
2534             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2535 0         0 }
2536             }
2537             return @glob;
2538             }
2539              
2540             #
2541             # Latin-2 parse line
2542             #
2543 0     0   0 sub _parse_line {
2544              
2545 0         0 my($line) = @_;
2546 0         0  
2547 0         0 $line .= ' ';
2548             my @piece = ();
2549             while ($line =~ /
2550             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2551             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2552 0 0       0 /oxmsg
2553             ) {
2554 0         0 push @piece, defined($1) ? $1 : $2;
2555             }
2556             return @piece;
2557             }
2558              
2559             #
2560             # Latin-2 parse path
2561             #
2562 0     0   0 sub _parse_path {
2563              
2564 0         0 my($path,$pathsep) = @_;
2565 0         0  
2566 0         0 $path .= '/';
2567             my @subpath = ();
2568             while ($path =~ /
2569             ((?: [^\/\\] )+?) [\/\\]
2570 0         0 /oxmsg
2571             ) {
2572             push @subpath, $1;
2573 0         0 }
2574 0         0  
2575 0         0 my $tail = pop @subpath;
2576             my $head = join $pathsep, @subpath;
2577             return $head, $tail;
2578             }
2579              
2580             #
2581             # via File::HomeDir::Windows 1.00
2582             #
2583             sub my_home_MSWin32 {
2584              
2585             # A lot of unix people and unix-derived tools rely on
2586 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2587 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2588             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2589             return $ENV{'HOME'};
2590             }
2591              
2592 0         0 # Do we have a user profile?
2593             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2594             return $ENV{'USERPROFILE'};
2595             }
2596              
2597 0         0 # Some Windows use something like $ENV{'HOME'}
2598             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2599             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2600 0         0 }
2601              
2602             return undef;
2603             }
2604              
2605             #
2606             # via File::HomeDir::Unix 1.00
2607 0     0 0 0 #
2608             sub my_home {
2609 0 0 0     0 my $home;
    0 0        
2610 0         0  
2611             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2612             $home = $ENV{'HOME'};
2613             }
2614              
2615             # This is from the original code, but I'm guessing
2616 0         0 # it means "login directory" and exists on some Unixes.
2617             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2618             $home = $ENV{'LOGDIR'};
2619             }
2620              
2621             ### More-desperate methods
2622              
2623 0         0 # Light desperation on any (Unixish) platform
2624             else {
2625             $home = CORE::eval q{ (getpwuid($<))[7] };
2626             }
2627              
2628 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2629 0         0 # For example, "nobody"-like users might use /nonexistant
2630             if (defined $home and ! -d($home)) {
2631 0         0 $home = undef;
2632             }
2633             return $home;
2634             }
2635              
2636             #
2637             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2638 0     0 0 0 #
2639             sub Elatin2::PREMATCH {
2640             return $`;
2641             }
2642              
2643             #
2644             # ${^MATCH}, $MATCH, $& the string that matched
2645 0     0 0 0 #
2646             sub Elatin2::MATCH {
2647             return $&;
2648             }
2649              
2650             #
2651             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2652 0     0 0 0 #
2653             sub Elatin2::POSTMATCH {
2654             return $';
2655             }
2656              
2657             #
2658             # Latin-2 character to order (with parameter)
2659             #
2660 0 0   0 1 0 sub Latin2::ord(;$) {
2661              
2662 0 0       0 local $_ = shift if @_;
2663 0         0  
2664 0         0 if (/\A ($q_char) /oxms) {
2665 0         0 my @ord = unpack 'C*', $1;
2666 0         0 my $ord = 0;
2667             while (my $o = shift @ord) {
2668 0         0 $ord = $ord * 0x100 + $o;
2669             }
2670             return $ord;
2671 0         0 }
2672             else {
2673             return CORE::ord $_;
2674             }
2675             }
2676              
2677             #
2678             # Latin-2 character to order (without parameter)
2679             #
2680 0 0   0 0 0 sub Latin2::ord_() {
2681 0         0  
2682 0         0 if (/\A ($q_char) /oxms) {
2683 0         0 my @ord = unpack 'C*', $1;
2684 0         0 my $ord = 0;
2685             while (my $o = shift @ord) {
2686 0         0 $ord = $ord * 0x100 + $o;
2687             }
2688             return $ord;
2689 0         0 }
2690             else {
2691             return CORE::ord $_;
2692             }
2693             }
2694              
2695             #
2696             # Latin-2 reverse
2697             #
2698 0 0   0 0 0 sub Latin2::reverse(@) {
2699 0         0  
2700             if (wantarray) {
2701             return CORE::reverse @_;
2702             }
2703             else {
2704              
2705             # One of us once cornered Larry in an elevator and asked him what
2706             # problem he was solving with this, but he looked as far off into
2707             # the distance as he could in an elevator and said, "It seemed like
2708 0         0 # a good idea at the time."
2709              
2710             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2711             }
2712             }
2713              
2714             #
2715             # Latin-2 getc (with parameter, without parameter)
2716             #
2717 0     0 0 0 sub Latin2::getc(;*@) {
2718 0 0       0  
2719 0 0 0     0 my($package) = caller;
2720             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2721 0         0 croak 'Too many arguments for Latin2::getc' if @_ and not wantarray;
  0         0  
2722 0         0  
2723 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2724 0         0 my $getc = '';
2725 0 0       0 for my $length ($length[0] .. $length[-1]) {
2726 0 0       0 $getc .= CORE::getc($fh);
2727 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2728             if ($getc =~ /\A ${Elatin2::dot_s} \z/oxms) {
2729             return wantarray ? ($getc,@_) : $getc;
2730             }
2731 0 0       0 }
2732             }
2733             return wantarray ? ($getc,@_) : $getc;
2734             }
2735              
2736             #
2737             # Latin-2 length by character
2738             #
2739 0 0   0 1 0 sub Latin2::length(;$) {
2740              
2741 0         0 local $_ = shift if @_;
2742 0         0  
2743             local @_ = /\G ($q_char) /oxmsg;
2744             return scalar @_;
2745             }
2746              
2747             #
2748             # Latin-2 substr by character
2749             #
2750             BEGIN {
2751              
2752             # P.232 The lvalue Attribute
2753             # in Chapter 6: Subroutines
2754             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2755              
2756             # P.336 The lvalue Attribute
2757             # in Chapter 7: Subroutines
2758             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2759              
2760             # P.144 8.4 Lvalue subroutines
2761             # in Chapter 8: perlsub: Perl subroutines
2762 204 50 0 204 1 146412 # 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  
2763              
2764             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2765             # vv----------------------*******
2766             sub Latin2::substr($$;$$) %s {
2767              
2768             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2769              
2770             # If the substring is beyond either end of the string, substr() returns the undefined
2771             # value and produces a warning. When used as an lvalue, specifying a substring that
2772             # is entirely outside the string raises an exception.
2773             # http://perldoc.perl.org/functions/substr.html
2774              
2775             # A return with no argument returns the scalar value undef in scalar context,
2776             # an empty list () in list context, and (naturally) nothing at all in void
2777             # context.
2778              
2779             my $offset = $_[1];
2780             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2781             return;
2782             }
2783              
2784             # substr($string,$offset,$length,$replacement)
2785             if (@_ == 4) {
2786             my(undef,undef,$length,$replacement) = @_;
2787             my $substr = join '', splice(@char, $offset, $length, $replacement);
2788             $_[0] = join '', @char;
2789              
2790             # return $substr; this doesn't work, don't say "return"
2791             $substr;
2792             }
2793              
2794             # substr($string,$offset,$length)
2795             elsif (@_ == 3) {
2796             my(undef,undef,$length) = @_;
2797             my $octet_offset = 0;
2798             my $octet_length = 0;
2799             if ($offset == 0) {
2800             $octet_offset = 0;
2801             }
2802             elsif ($offset > 0) {
2803             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2804             }
2805             else {
2806             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2807             }
2808             if ($length == 0) {
2809             $octet_length = 0;
2810             }
2811             elsif ($length > 0) {
2812             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2813             }
2814             else {
2815             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2816             }
2817             CORE::substr($_[0], $octet_offset, $octet_length);
2818             }
2819              
2820             # substr($string,$offset)
2821             else {
2822             my $octet_offset = 0;
2823             if ($offset == 0) {
2824             $octet_offset = 0;
2825             }
2826             elsif ($offset > 0) {
2827             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2828             }
2829             else {
2830             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2831             }
2832             CORE::substr($_[0], $octet_offset);
2833             }
2834             }
2835             END
2836             }
2837              
2838             #
2839             # Latin-2 index by character
2840             #
2841 0     0 1 0 sub Latin2::index($$;$) {
2842 0 0       0  
2843 0         0 my $index;
2844             if (@_ == 3) {
2845             $index = Elatin2::index($_[0], $_[1], CORE::length(Latin2::substr($_[0], 0, $_[2])));
2846 0         0 }
2847             else {
2848             $index = Elatin2::index($_[0], $_[1]);
2849 0 0       0 }
2850 0         0  
2851             if ($index == -1) {
2852             return -1;
2853 0         0 }
2854             else {
2855             return Latin2::length(CORE::substr $_[0], 0, $index);
2856             }
2857             }
2858              
2859             #
2860             # Latin-2 rindex by character
2861             #
2862 0     0 1 0 sub Latin2::rindex($$;$) {
2863 0 0       0  
2864 0         0 my $rindex;
2865             if (@_ == 3) {
2866             $rindex = Elatin2::rindex($_[0], $_[1], CORE::length(Latin2::substr($_[0], 0, $_[2])));
2867 0         0 }
2868             else {
2869             $rindex = Elatin2::rindex($_[0], $_[1]);
2870 0 0       0 }
2871 0         0  
2872             if ($rindex == -1) {
2873             return -1;
2874 0         0 }
2875             else {
2876             return Latin2::length(CORE::substr $_[0], 0, $rindex);
2877             }
2878             }
2879              
2880 204     204   1969 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         454  
  204         26481  
2881             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2882             use vars qw($slash); $slash = 'm//';
2883              
2884             # ord() to ord() or Latin2::ord()
2885             my $function_ord = 'ord';
2886              
2887             # ord to ord or Latin2::ord_
2888             my $function_ord_ = 'ord';
2889              
2890             # reverse to reverse or Latin2::reverse
2891             my $function_reverse = 'reverse';
2892              
2893             # getc to getc or Latin2::getc
2894             my $function_getc = 'getc';
2895              
2896             # P.1023 Appendix W.9 Multibyte Anchoring
2897             # of ISBN 1-56592-224-7 CJKV Information Processing
2898              
2899 204     204   1565 my $anchor = '';
  204     0   362  
  204         9729160  
2900              
2901             use vars qw($nest);
2902              
2903             # regexp of nested parens in qqXX
2904              
2905             # P.340 Matching Nested Constructs with Embedded Code
2906             # in Chapter 7: Perl
2907             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2908              
2909             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2910             [^\\()] |
2911             \( (?{$nest++}) |
2912             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2913             \\ [^c] |
2914             \\c[\x40-\x5F] |
2915             [\x00-\xFF]
2916             }xms;
2917              
2918             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2919             [^\\{}] |
2920             \{ (?{$nest++}) |
2921             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2922             \\ [^c] |
2923             \\c[\x40-\x5F] |
2924             [\x00-\xFF]
2925             }xms;
2926              
2927             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2928             [^\\\[\]] |
2929             \[ (?{$nest++}) |
2930             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2931             \\ [^c] |
2932             \\c[\x40-\x5F] |
2933             [\x00-\xFF]
2934             }xms;
2935              
2936             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2937             [^\\<>] |
2938             \< (?{$nest++}) |
2939             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2940             \\ [^c] |
2941             \\c[\x40-\x5F] |
2942             [\x00-\xFF]
2943             }xms;
2944              
2945             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2946             (?: ::)? (?:
2947             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2948             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2949             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2950             ))
2951             }xms;
2952              
2953             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2954             (?: ::)? (?:
2955             (?>[0-9]+) |
2956             [^a-zA-Z_0-9\[\]] |
2957             ^[A-Z] |
2958             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2959             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2960             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2961             ))
2962             }xms;
2963              
2964             my $qq_substr = qr{(?> Char::substr | Latin2::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2965             }xms;
2966              
2967             # regexp of nested parens in qXX
2968             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2969             [^()] |
2970             \( (?{$nest++}) |
2971             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2972             [\x00-\xFF]
2973             }xms;
2974              
2975             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2976             [^\{\}] |
2977             \{ (?{$nest++}) |
2978             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2979             [\x00-\xFF]
2980             }xms;
2981              
2982             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2983             [^\[\]] |
2984             \[ (?{$nest++}) |
2985             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2986             [\x00-\xFF]
2987             }xms;
2988              
2989             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2990             [^<>] |
2991             \< (?{$nest++}) |
2992             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2993             [\x00-\xFF]
2994             }xms;
2995              
2996             my $matched = '';
2997             my $s_matched = '';
2998              
2999             my $tr_variable = ''; # variable of tr///
3000             my $sub_variable = ''; # variable of s///
3001             my $bind_operator = ''; # =~ or !~
3002              
3003             my @heredoc = (); # here document
3004             my @heredoc_delimiter = ();
3005             my $here_script = ''; # here script
3006              
3007             #
3008             # escape Latin-2 script
3009 0 50   204 0 0 #
3010             sub Latin2::escape(;$) {
3011             local($_) = $_[0] if @_;
3012              
3013             # P.359 The Study Function
3014             # in Chapter 7: Perl
3015 204         613 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3016              
3017             study $_; # Yes, I studied study yesterday.
3018              
3019             # while all script
3020              
3021             # 6.14. Matching from Where the Last Pattern Left Off
3022             # in Chapter 6. Pattern Matching
3023             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3024             # (and so on)
3025              
3026             # one member of Tag-team
3027             #
3028             # P.128 Start of match (or end of previous match): \G
3029             # P.130 Advanced Use of \G with Perl
3030             # in Chapter 3: Overview of Regular Expression Features and Flavors
3031             # P.255 Use leading anchors
3032             # P.256 Expose ^ and \G at the front expressions
3033             # in Chapter 6: Crafting an Efficient Expression
3034             # P.315 "Tag-team" matching with /gc
3035             # in Chapter 7: Perl
3036 204         398 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3037 204         2503  
3038 204         732 my $e_script = '';
3039             while (not /\G \z/oxgc) { # member
3040             $e_script .= Latin2::escape_token();
3041 74977         126431 }
3042              
3043             return $e_script;
3044             }
3045              
3046             #
3047             # escape Latin-2 token of script
3048             #
3049             sub Latin2::escape_token {
3050              
3051 204     74977 0 2827 # \n output here document
3052              
3053             my $ignore_modules = join('|', qw(
3054             utf8
3055             bytes
3056             charnames
3057             I18N::Japanese
3058             I18N::Collate
3059             I18N::JExt
3060             File::DosGlob
3061             Wild
3062             Wildcard
3063             Japanese
3064             ));
3065              
3066             # another member of Tag-team
3067             #
3068             # P.315 "Tag-team" matching with /gc
3069             # in Chapter 7: Perl
3070 74977 100 100     88599 # 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          
3071 74977         2880111  
3072 12532 100       15474 if (/\G ( \n ) /oxgc) { # another member (and so on)
3073 12532         21862 my $heredoc = '';
3074             if (scalar(@heredoc_delimiter) >= 1) {
3075 174         233 $slash = 'm//';
3076 174         311  
3077             $heredoc = join '', @heredoc;
3078             @heredoc = ();
3079 174         313  
3080 174         288 # skip here document
3081             for my $heredoc_delimiter (@heredoc_delimiter) {
3082 174         1084 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3083             }
3084 174         322 @heredoc_delimiter = ();
3085              
3086 174         266 $here_script = '';
3087             }
3088             return "\n" . $heredoc;
3089             }
3090 12532         36700  
3091             # ignore space, comment
3092             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3093              
3094             # if (, elsif (, unless (, while (, until (, given (, and when (
3095              
3096             # given, when
3097              
3098             # P.225 The given Statement
3099             # in Chapter 15: Smart Matching and given-when
3100             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3101              
3102             # P.133 The given Statement
3103             # in Chapter 4: Statements and Declarations
3104             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3105 18024         74669  
3106 1401         11779 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3107             $slash = 'm//';
3108             return $1;
3109             }
3110              
3111             # scalar variable ($scalar = ...) =~ tr///;
3112             # scalar variable ($scalar = ...) =~ s///;
3113              
3114             # state
3115              
3116             # P.68 Persistent, Private Variables
3117             # in Chapter 4: Subroutines
3118             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3119              
3120             # P.160 Persistent Lexically Scoped Variables: state
3121             # in Chapter 4: Statements and Declarations
3122             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3123              
3124             # (and so on)
3125 1401         4836  
3126             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3127 86 50       217 my $e_string = e_string($1);
    50          
3128 86         2119  
3129 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3130 0         0 $tr_variable = $e_string . e_string($1);
3131 0         0 $bind_operator = $2;
3132             $slash = 'm//';
3133             return '';
3134 0         0 }
3135 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3136 0         0 $sub_variable = $e_string . e_string($1);
3137 0         0 $bind_operator = $2;
3138             $slash = 'm//';
3139             return '';
3140 0         0 }
3141 86         149 else {
3142             $slash = 'div';
3143             return $e_string;
3144             }
3145             }
3146              
3147 86         284 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
3148 4         9 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3149             $slash = 'div';
3150             return q{Elatin2::PREMATCH()};
3151             }
3152              
3153 4         13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
3154 28         54 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3155             $slash = 'div';
3156             return q{Elatin2::MATCH()};
3157             }
3158              
3159 28         87 # $', ${'} --> $', ${'}
3160 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3161             $slash = 'div';
3162             return $1;
3163             }
3164              
3165 1         6 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
3166 3         5 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3167             $slash = 'div';
3168             return q{Elatin2::POSTMATCH()};
3169             }
3170              
3171             # scalar variable $scalar =~ tr///;
3172             # scalar variable $scalar =~ s///;
3173             # substr() =~ tr///;
3174 3         11 # substr() =~ s///;
3175             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3176 1671 100       3508 my $scalar = e_string($1);
    100          
3177 1671         6601  
3178 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3179 1         3 $tr_variable = $scalar;
3180 1         2 $bind_operator = $1;
3181             $slash = 'm//';
3182             return '';
3183 1         3 }
3184 61         127 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3185 61         128 $sub_variable = $scalar;
3186 61         95 $bind_operator = $1;
3187             $slash = 'm//';
3188             return '';
3189 61         176 }
3190 1609         2315 else {
3191             $slash = 'div';
3192             return $scalar;
3193             }
3194             }
3195              
3196 1609         4545 # end of statement
3197             elsif (/\G ( [,;] ) /oxgc) {
3198             $slash = 'm//';
3199 5008         7173  
3200             # clear tr/// variable
3201             $tr_variable = '';
3202 5008         5745  
3203             # clear s/// variable
3204 5008         6262 $sub_variable = '';
3205              
3206 5008         5558 $bind_operator = '';
3207              
3208             return $1;
3209             }
3210              
3211 5008         17213 # bareword
3212             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3213             return $1;
3214             }
3215              
3216 0         0 # $0 --> $0
3217 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3218             $slash = 'div';
3219             return $1;
3220 2         7 }
3221 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3222             $slash = 'div';
3223             return $1;
3224             }
3225              
3226 0         0 # $$ --> $$
3227 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3228             $slash = 'div';
3229             return $1;
3230             }
3231              
3232             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3233 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3234 4         8 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3235             $slash = 'div';
3236             return e_capture($1);
3237 4         8 }
3238 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3239             $slash = 'div';
3240             return e_capture($1);
3241             }
3242              
3243 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3244 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3245             $slash = 'div';
3246             return e_capture($1.'->'.$2);
3247             }
3248              
3249 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3250 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3251             $slash = 'div';
3252             return e_capture($1.'->'.$2);
3253             }
3254              
3255 0         0 # $$foo
3256 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3257             $slash = 'div';
3258             return e_capture($1);
3259             }
3260              
3261 0         0 # ${ foo }
3262 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3263             $slash = 'div';
3264             return '${' . $1 . '}';
3265             }
3266              
3267 0         0 # ${ ... }
3268 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3269             $slash = 'div';
3270             return e_capture($1);
3271             }
3272              
3273             # variable or function
3274 0         0 # $ @ % & * $ #
3275 42         70 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) {
3276             $slash = 'div';
3277             return $1;
3278             }
3279             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3280 42         137 # $ @ # \ ' " / ? ( ) [ ] < >
3281 62         118 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3282             $slash = 'div';
3283             return $1;
3284             }
3285              
3286 62         211 # while ()
3287             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3288             return $1;
3289             }
3290              
3291             # while () --- glob
3292              
3293             # avoid "Error: Runtime exception" of perl version 5.005_03
3294 0         0  
3295             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3296             return 'while ($_ = Elatin2::glob("' . $1 . '"))';
3297             }
3298              
3299 0         0 # while (glob)
3300             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3301             return 'while ($_ = Elatin2::glob_)';
3302             }
3303              
3304 0         0 # while (glob(WILDCARD))
3305             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3306             return 'while ($_ = Elatin2::glob';
3307             }
3308 0         0  
  248         557  
3309             # doit if, doit unless, doit while, doit until, doit for, doit when
3310             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3311 248         865  
  19         35  
3312 19         65 # subroutines of package Elatin2
  0         0  
3313 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         15  
3314 13         33 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3315 0         0 elsif (/\G \b Latin2::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         197  
3316 114         334 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3317 2         7 elsif (/\G \b Latin2::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin2::escape'; }
  0         0  
3318 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3319 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::chop'; }
  0         0  
3320 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3321 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3322 0         0 elsif (/\G \b Latin2::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin2::index'; }
  2         5  
3323 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::index'; }
  0         0  
3324 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3325 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3326 0         0 elsif (/\G \b Latin2::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin2::rindex'; }
  1         2  
3327 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::rindex'; }
  0         0  
3328 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::lc'; }
  1         4  
3329 1         4 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::lcfirst'; }
  0         0  
3330 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::uc'; }
  6         10  
3331             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::ucfirst'; }
3332             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::fc'; }
3333 6         16  
  0         0  
3334 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3335 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3336 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3337 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3338 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3339 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3340             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3341 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  
3342 0         0  
  0         0  
3343 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3344 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3345 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3346 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3347 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3348             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3349             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3350 0         0  
  0         0  
3351 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3352 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3353 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3354             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3355 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         3  
3356 2         7  
  2         5  
3357 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         62  
3358 36         108 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3359 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::chr'; }
  8         15  
3360 8         25 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3361 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3362 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin2::glob'; }
  0         0  
3363 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::lc_'; }
  0         0  
3364 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::lcfirst_'; }
  0         0  
3365 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::uc_'; }
  0         0  
3366 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::ucfirst_'; }
  0         0  
3367             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::fc_'; }
3368 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3369 0         0  
  0         0  
3370 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3371 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3372 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::chr_'; }
  0         0  
3373 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3374 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3375 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin2::glob_'; }
  8         20  
3376             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3377             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3378 8         43 # split
3379             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3380 87         189 $slash = 'm//';
3381 87         136  
3382 87         335 my $e = '';
3383             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3384             $e .= $1;
3385             }
3386 85 100       323  
  87 100       5993  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3387             # end of split
3388             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin2::split' . $e; }
3389 2         8  
3390             # split scalar value
3391             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin2::split' . $e . e_string($1); }
3392 1         6  
3393 0         0 # split literal space
3394 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin2::split' . $e . qq {qq$1 $2}; }
3395 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3396 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3397 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3398 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3399 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin2::split' . $e . qq{$1qq$2 $3}; }
3400 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin2::split' . $e . qq {q$1 $2}; }
3401 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3402 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3403 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3404 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3405 10         56 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin2::split' . $e . qq {$1q$2 $3}; }
3406             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin2::split' . $e . qq {' '}; }
3407             elsif (/\G " [ ] " /oxgc) { return 'Elatin2::split' . $e . qq {" "}; }
3408              
3409 0 0       0 # split qq//
  0         0  
3410             elsif (/\G \b (qq) \b /oxgc) {
3411 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3412 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3413 0         0 while (not /\G \z/oxgc) {
3414 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3415 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3416 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3417 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3418 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3419             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3420 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3421             }
3422             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3423             }
3424             }
3425              
3426 0 50       0 # split qr//
  12         505  
3427             elsif (/\G \b (qr) \b /oxgc) {
3428 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3429 12 50       64 else {
  12 50       3290  
    50          
    50          
    50          
    50          
    50          
    50          
3430 0         0 while (not /\G \z/oxgc) {
3431 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3432 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3433 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3434 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3435 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3436 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3437             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3438 12         99 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3439             }
3440             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3441             }
3442             }
3443              
3444 0 0       0 # split q//
  0         0  
3445             elsif (/\G \b (q) \b /oxgc) {
3446 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3447 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3448 0         0 while (not /\G \z/oxgc) {
3449 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3450 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3451 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3452 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3453 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3454             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3455 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3456             }
3457             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3458             }
3459             }
3460              
3461 0 50       0 # split m//
  18         492  
3462             elsif (/\G \b (m) \b /oxgc) {
3463 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3464 18 50       75 else {
  18 50       3774  
    50          
    50          
    50          
    50          
    50          
    50          
3465 0         0 while (not /\G \z/oxgc) {
3466 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3467 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3468 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3469 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3470 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3471 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3472             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3473 18         105 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3474             }
3475             die __FILE__, ": Search pattern not terminated\n";
3476             }
3477             }
3478              
3479 0         0 # split ''
3480 0         0 elsif (/\G (\') /oxgc) {
3481 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3482 0         0 while (not /\G \z/oxgc) {
3483 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3484 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3485             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3486 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3487             }
3488             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3489             }
3490              
3491 0         0 # split ""
3492 0         0 elsif (/\G (\") /oxgc) {
3493 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3494 0         0 while (not /\G \z/oxgc) {
3495 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3496 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3497             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3498 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3499             }
3500             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3501             }
3502              
3503 0         0 # split //
3504 44         126 elsif (/\G (\/) /oxgc) {
3505 44 50       156 my $regexp = '';
  381 50       1529  
    100          
    50          
3506 0         0 while (not /\G \z/oxgc) {
3507 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3508 44         213 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3509             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3510 337         706 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3511             }
3512             die __FILE__, ": Search pattern not terminated\n";
3513             }
3514             }
3515              
3516             # tr/// or y///
3517              
3518             # about [cdsrbB]* (/B modifier)
3519             #
3520             # P.559 appendix C
3521             # of ISBN 4-89052-384-7 Programming perl
3522             # (Japanese title is: Perl puroguramingu)
3523 0         0  
3524             elsif (/\G \b ( tr | y ) \b /oxgc) {
3525             my $ope = $1;
3526 3 50       7  
3527 3         43 # $1 $2 $3 $4 $5 $6
3528 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3529             my @tr = ($tr_variable,$2);
3530             return e_tr(@tr,'',$4,$6);
3531 0         0 }
3532 3         6 else {
3533 3 50       10 my $e = '';
  3 50       238  
    50          
    50          
    50          
    50          
3534             while (not /\G \z/oxgc) {
3535 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3536 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3537 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3538 0         0 while (not /\G \z/oxgc) {
3539 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3540 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3541 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3542 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3543             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3544 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3545             }
3546             die __FILE__, ": Transliteration replacement not terminated\n";
3547 0         0 }
3548 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3549 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3550 0         0 while (not /\G \z/oxgc) {
3551 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3552 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3553 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3554 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3555             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3556 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3557             }
3558             die __FILE__, ": Transliteration replacement not terminated\n";
3559 0         0 }
3560 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3561 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3562 0         0 while (not /\G \z/oxgc) {
3563 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3564 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3565 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3566 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3567             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3568 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3569             }
3570             die __FILE__, ": Transliteration replacement not terminated\n";
3571 0         0 }
3572 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3573 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3574 0         0 while (not /\G \z/oxgc) {
3575 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3576 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3577 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3578 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3579             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3580 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3581             }
3582             die __FILE__, ": Transliteration replacement not terminated\n";
3583             }
3584 0         0 # $1 $2 $3 $4 $5 $6
3585 3         12 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3586             my @tr = ($tr_variable,$2);
3587             return e_tr(@tr,'',$4,$6);
3588 3         11 }
3589             }
3590             die __FILE__, ": Transliteration pattern not terminated\n";
3591             }
3592             }
3593              
3594 0         0 # qq//
3595             elsif (/\G \b (qq) \b /oxgc) {
3596             my $ope = $1;
3597 2180 50       4755  
3598 2180         4215 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3599 0         0 if (/\G (\#) /oxgc) { # qq# #
3600 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3601 0         0 while (not /\G \z/oxgc) {
3602 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3603 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3604             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3605 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3606             }
3607             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3608             }
3609 0         0  
3610 2180         3009 else {
3611 2180 50       5068 my $e = '';
  2180 50       8713  
    100          
    50          
    50          
    0          
3612             while (not /\G \z/oxgc) {
3613             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3614              
3615 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3616 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3617 0         0 my $qq_string = '';
3618 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3619 0         0 while (not /\G \z/oxgc) {
3620 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3621             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3622 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3623 0         0 elsif (/\G (\)) /oxgc) {
3624             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3625 0         0 else { $qq_string .= $1; }
3626             }
3627 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3628             }
3629             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3630             }
3631              
3632 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3633 2150         2822 elsif (/\G (\{) /oxgc) { # qq { }
3634 2150         2894 my $qq_string = '';
3635 2150 100       4260 local $nest = 1;
  84006 50       271869  
    100          
    100          
    50          
3636 722         1408 while (not /\G \z/oxgc) {
3637 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1551  
3638             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3639 1153 100       1886 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5157  
3640 2150         4562 elsif (/\G (\}) /oxgc) {
3641             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3642 1153         2300 else { $qq_string .= $1; }
3643             }
3644 78828         155563 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3645             }
3646             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3647             }
3648              
3649 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3650 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3651 0         0 my $qq_string = '';
3652 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3653 0         0 while (not /\G \z/oxgc) {
3654 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3655             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3656 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3657 0         0 elsif (/\G (\]) /oxgc) {
3658             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3659 0         0 else { $qq_string .= $1; }
3660             }
3661 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3662             }
3663             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3664             }
3665              
3666 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3667 30         49 elsif (/\G (\<) /oxgc) { # qq < >
3668 30         45 my $qq_string = '';
3669 30 100       100 local $nest = 1;
  1166 50       3772  
    50          
    100          
    50          
3670 22         49 while (not /\G \z/oxgc) {
3671 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3672             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3673 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         117  
3674 30         71 elsif (/\G (\>) /oxgc) {
3675             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3676 0         0 else { $qq_string .= $1; }
3677             }
3678 1114         2227 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3679             }
3680             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3681             }
3682              
3683 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3684 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3685 0         0 my $delimiter = $1;
3686 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3687 0         0 while (not /\G \z/oxgc) {
3688 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3689 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3690             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3691 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3692             }
3693             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3694 0         0 }
3695             }
3696             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3697             }
3698             }
3699              
3700 0         0 # qr//
3701 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3702 0         0 my $ope = $1;
3703             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3704             return e_qr($ope,$1,$3,$2,$4);
3705 0         0 }
3706 0         0 else {
3707 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3708 0         0 while (not /\G \z/oxgc) {
3709 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3710 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3711 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3712 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3713 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3714 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3715             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3716 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3717             }
3718             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3719             }
3720             }
3721              
3722 0         0 # qw//
3723 16 50       46 elsif (/\G \b (qw) \b /oxgc) {
3724 16         80 my $ope = $1;
3725             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3726             return e_qw($ope,$1,$3,$2);
3727 0         0 }
3728 16         33 else {
3729 16 50       55 my $e = '';
  16 50       97  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3730             while (not /\G \z/oxgc) {
3731 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3732 16         61  
3733             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3734 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3735 0         0  
3736             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3737 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3738 0         0  
3739             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3740 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3741 0         0  
3742             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3743 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3744 0         0  
3745             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3746 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3747             }
3748             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3749             }
3750             }
3751              
3752 0         0 # qx//
3753 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3754 0         0 my $ope = $1;
3755             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3756             return e_qq($ope,$1,$3,$2);
3757 0         0 }
3758 0         0 else {
3759 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3760 0         0 while (not /\G \z/oxgc) {
3761 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3762 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3763 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3764 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3765 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3766             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3767 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3768             }
3769             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3770             }
3771             }
3772              
3773 0         0 # q//
3774             elsif (/\G \b (q) \b /oxgc) {
3775             my $ope = $1;
3776              
3777             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3778              
3779             # avoid "Error: Runtime exception" of perl version 5.005_03
3780 410 50       1009 # (and so on)
3781 410         980  
3782 0         0 if (/\G (\#) /oxgc) { # q# #
3783 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3784 0         0 while (not /\G \z/oxgc) {
3785 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3786 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3787             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3788 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3789             }
3790             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3791             }
3792 0         0  
3793 410         708 else {
3794 410 50       1332 my $e = '';
  410 50       2010  
    100          
    50          
    100          
    50          
3795             while (not /\G \z/oxgc) {
3796             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3797              
3798 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3799 0         0 elsif (/\G (\() /oxgc) { # q ( )
3800 0         0 my $q_string = '';
3801 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3802 0         0 while (not /\G \z/oxgc) {
3803 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3804 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3805             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3806 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3807 0         0 elsif (/\G (\)) /oxgc) {
3808             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3809 0         0 else { $q_string .= $1; }
3810             }
3811 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3812             }
3813             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3814             }
3815              
3816 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3817 404         805 elsif (/\G (\{) /oxgc) { # q { }
3818 404         690 my $q_string = '';
3819 404 50       1260 local $nest = 1;
  6770 50       25250  
    50          
    100          
    100          
    50          
3820 0         0 while (not /\G \z/oxgc) {
3821 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3822 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         169  
3823             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3824 107 100       187 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1145  
3825 404         1111 elsif (/\G (\}) /oxgc) {
3826             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3827 107         211 else { $q_string .= $1; }
3828             }
3829 6152         11417 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3830             }
3831             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3832             }
3833              
3834 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3835 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3836 0         0 my $q_string = '';
3837 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3838 0         0 while (not /\G \z/oxgc) {
3839 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3840 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3841             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3842 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3843 0         0 elsif (/\G (\]) /oxgc) {
3844             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3845 0         0 else { $q_string .= $1; }
3846             }
3847 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3848             }
3849             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3850             }
3851              
3852 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3853 5         11 elsif (/\G (\<) /oxgc) { # q < >
3854 5         10 my $q_string = '';
3855 5 50       19 local $nest = 1;
  88 50       374  
    50          
    50          
    100          
    50          
3856 0         0 while (not /\G \z/oxgc) {
3857 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3858 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3859             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3860 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         14  
3861 5         15 elsif (/\G (\>) /oxgc) {
3862             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3863 0         0 else { $q_string .= $1; }
3864             }
3865 83         283 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3866             }
3867             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3868             }
3869              
3870 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3871 1         2 elsif (/\G (\S) /oxgc) { # q * *
3872 1         2 my $delimiter = $1;
3873 1 50       3 my $q_string = '';
  14 50       65  
    100          
    50          
3874 0         0 while (not /\G \z/oxgc) {
3875 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3876 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3877             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3878 13         24 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3879             }
3880             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3881 0         0 }
3882             }
3883             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3884             }
3885             }
3886              
3887 0         0 # m//
3888 209 50       515 elsif (/\G \b (m) \b /oxgc) {
3889 209         1441 my $ope = $1;
3890             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3891             return e_qr($ope,$1,$3,$2,$4);
3892 0         0 }
3893 209         358 else {
3894 209 50       566 my $e = '';
  209 50       10540  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3895 0         0 while (not /\G \z/oxgc) {
3896 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3897 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3898 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3899 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3900 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3901 10         32 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3902 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3903             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3904 199         847 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3905             }
3906             die __FILE__, ": Search pattern not terminated\n";
3907             }
3908             }
3909              
3910             # s///
3911              
3912             # about [cegimosxpradlunbB]* (/cg modifier)
3913             #
3914             # P.67 Pattern-Matching Operators
3915             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3916 0         0  
3917             elsif (/\G \b (s) \b /oxgc) {
3918             my $ope = $1;
3919 97 100       261  
3920 97         1908 # $1 $2 $3 $4 $5 $6
3921             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3922             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3923 1         6 }
3924 96         215 else {
3925 96 50       303 my $e = '';
  96 50       12379  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3926             while (not /\G \z/oxgc) {
3927 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3928 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3929 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3930             while (not /\G \z/oxgc) {
3931 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3932 0         0 # $1 $2 $3 $4
3933 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942             }
3943             die __FILE__, ": Substitution replacement not terminated\n";
3944 0         0 }
3945 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3946 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3947             while (not /\G \z/oxgc) {
3948 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3949 0         0 # $1 $2 $3 $4
3950 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959             }
3960             die __FILE__, ": Substitution replacement not terminated\n";
3961 0         0 }
3962 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3963 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3964             while (not /\G \z/oxgc) {
3965 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3966 0         0 # $1 $2 $3 $4
3967 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974             }
3975             die __FILE__, ": Substitution replacement not terminated\n";
3976 0         0 }
3977 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3978 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3979             while (not /\G \z/oxgc) {
3980 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3981 0         0 # $1 $2 $3 $4
3982 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3985 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3986 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3987 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3988 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3989             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3990 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3991             }
3992             die __FILE__, ": Substitution replacement not terminated\n";
3993             }
3994 0         0 # $1 $2 $3 $4 $5 $6
3995             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3996             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3997             }
3998 21         66 # $1 $2 $3 $4 $5 $6
3999             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4000             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4001             }
4002 0         0 # $1 $2 $3 $4 $5 $6
4003             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4004             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4005             }
4006 0         0 # $1 $2 $3 $4 $5 $6
4007             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4008             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4009 75         343 }
4010             }
4011             die __FILE__, ": Substitution pattern not terminated\n";
4012             }
4013             }
4014 0         0  
4015 0         0 # require ignore module
4016 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4017             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4018             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4019 0         0  
4020 37         314 # use strict; --> use strict; no strict qw(refs);
4021 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4022             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4023             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4024              
4025 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4026 2         20 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4027             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4028             return "use $1; no strict qw(refs);";
4029 0         0 }
4030             else {
4031             return "use $1;";
4032             }
4033 2 0 0     11 }
      0        
4034 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4035             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4036             return "use $1; no strict qw(refs);";
4037 0         0 }
4038             else {
4039             return "use $1;";
4040             }
4041             }
4042 0         0  
4043 2         15 # ignore use module
4044 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4045             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4046             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4047 0         0  
4048 0         0 # ignore no module
4049 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4050             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4051             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4052 0         0  
4053             # use else
4054             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4055 0         0  
4056             # use else
4057             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4058              
4059 2         10 # ''
4060 848         1846 elsif (/\G (?
4061 848 100       2307 my $q_string = '';
  8254 100       42284  
    100          
    50          
4062 4         10 while (not /\G \z/oxgc) {
4063 48         85 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4064 848         1881 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4065             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4066 7354         30367 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4067             }
4068             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4069             }
4070              
4071 0         0 # ""
4072 1824         7732 elsif (/\G (\") /oxgc) {
4073 1824 100       4398 my $qq_string = '';
  35289 100       111960  
    100          
    50          
4074 67         157 while (not /\G \z/oxgc) {
4075 12         28 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4076 1824         3981 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4077             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4078 33386         70522 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4079             }
4080             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4081             }
4082              
4083 0         0 # ``
4084 1         2 elsif (/\G (\`) /oxgc) {
4085 1 50       5 my $qx_string = '';
  19 50       66  
    100          
    50          
4086 0         0 while (not /\G \z/oxgc) {
4087 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4088 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4089             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4090 18         34 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4091             }
4092             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4093             }
4094              
4095 0         0 # // --- not divide operator (num / num), not defined-or
4096 453         1475 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4097 453 50       1419 my $regexp = '';
  4496 50       14966  
    100          
    50          
4098 0         0 while (not /\G \z/oxgc) {
4099 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4100 453         1587 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4101             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4102 4043         8083 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4103             }
4104             die __FILE__, ": Search pattern not terminated\n";
4105             }
4106              
4107 0         0 # ?? --- not conditional operator (condition ? then : else)
4108 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4109 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4110 0         0 while (not /\G \z/oxgc) {
4111 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4112 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4113             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4114 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4115             }
4116             die __FILE__, ": Search pattern not terminated\n";
4117             }
4118 0         0  
  0         0  
4119             # <<>> (a safer ARGV)
4120             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4121 0         0  
  0         0  
4122             # << (bit shift) --- not here document
4123             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4124              
4125 0         0 # <<~'HEREDOC'
4126 6         15 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4127 6         11 $slash = 'm//';
4128             my $here_quote = $1;
4129             my $delimiter = $2;
4130 6 50       11  
4131 6         13 # get here document
4132 6         31 if ($here_script eq '') {
4133             $here_script = CORE::substr $_, pos $_;
4134 6 50       30 $here_script =~ s/.*?\n//oxm;
4135 6         64 }
4136 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4137 6         8 my $heredoc = $1;
4138 6         100 my $indent = $2;
4139 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4140             push @heredoc, $heredoc . qq{\n$delimiter\n};
4141             push @heredoc_delimiter, qq{\\s*$delimiter};
4142 6         15 }
4143             else {
4144 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4145             }
4146             return qq{<<'$delimiter'};
4147             }
4148              
4149             # <<~\HEREDOC
4150              
4151             # P.66 2.6.6. "Here" Documents
4152             # in Chapter 2: Bits and Pieces
4153             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4154              
4155             # P.73 "Here" Documents
4156             # in Chapter 2: Bits and Pieces
4157             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4158 6         70  
4159 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4160 3         7 $slash = 'm//';
4161             my $here_quote = $1;
4162             my $delimiter = $2;
4163 3 50       6  
4164 3         6 # get here document
4165 3         21 if ($here_script eq '') {
4166             $here_script = CORE::substr $_, pos $_;
4167 3 50       18 $here_script =~ s/.*?\n//oxm;
4168 3         46 }
4169 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4170 3         7 my $heredoc = $1;
4171 3         89 my $indent = $2;
4172 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
4173             push @heredoc, $heredoc . qq{\n$delimiter\n};
4174             push @heredoc_delimiter, qq{\\s*$delimiter};
4175 3         8 }
4176             else {
4177 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4178             }
4179             return qq{<<\\$delimiter};
4180             }
4181              
4182 3         13 # <<~"HEREDOC"
4183 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4184 6         12 $slash = 'm//';
4185             my $here_quote = $1;
4186             my $delimiter = $2;
4187 6 50       12  
4188 6         13 # get here document
4189 6         31 if ($here_script eq '') {
4190             $here_script = CORE::substr $_, pos $_;
4191 6 50       31 $here_script =~ s/.*?\n//oxm;
4192 6         90 }
4193 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4194 6         8 my $heredoc = $1;
4195 6         51 my $indent = $2;
4196 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
4197             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4198             push @heredoc_delimiter, qq{\\s*$delimiter};
4199 6         15 }
4200             else {
4201 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4202             }
4203             return qq{<<"$delimiter"};
4204             }
4205              
4206 6         23 # <<~HEREDOC
4207 3         8 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4208 3         6 $slash = 'm//';
4209             my $here_quote = $1;
4210             my $delimiter = $2;
4211 3 50       7  
4212 3         8 # get here document
4213 3         14 if ($here_script eq '') {
4214             $here_script = CORE::substr $_, pos $_;
4215 3 50       25 $here_script =~ s/.*?\n//oxm;
4216 3         40 }
4217 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4218 3         8 my $heredoc = $1;
4219 3         49 my $indent = $2;
4220 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4221             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4222             push @heredoc_delimiter, qq{\\s*$delimiter};
4223 3         8 }
4224             else {
4225 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4226             }
4227             return qq{<<$delimiter};
4228             }
4229              
4230 3         14 # <<~`HEREDOC`
4231 6         12 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4232 6         11 $slash = 'm//';
4233             my $here_quote = $1;
4234             my $delimiter = $2;
4235 6 50       9  
4236 6         14 # get here document
4237 6         14 if ($here_script eq '') {
4238             $here_script = CORE::substr $_, pos $_;
4239 6 50       30 $here_script =~ s/.*?\n//oxm;
4240 6         61 }
4241 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4242 6         7 my $heredoc = $1;
4243 6         49 my $indent = $2;
4244 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4245             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4246             push @heredoc_delimiter, qq{\\s*$delimiter};
4247 6         13 }
4248             else {
4249 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4250             }
4251             return qq{<<`$delimiter`};
4252             }
4253              
4254 6         31 # <<'HEREDOC'
4255 72         127 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4256 72         168 $slash = 'm//';
4257             my $here_quote = $1;
4258             my $delimiter = $2;
4259 72 50       114  
4260 72         138 # get here document
4261 72         368 if ($here_script eq '') {
4262             $here_script = CORE::substr $_, pos $_;
4263 72 50       399 $here_script =~ s/.*?\n//oxm;
4264 72         525 }
4265 72         219 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4266             push @heredoc, $1 . qq{\n$delimiter\n};
4267             push @heredoc_delimiter, $delimiter;
4268 72         117 }
4269             else {
4270 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4271             }
4272             return $here_quote;
4273             }
4274              
4275             # <<\HEREDOC
4276              
4277             # P.66 2.6.6. "Here" Documents
4278             # in Chapter 2: Bits and Pieces
4279             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4280              
4281             # P.73 "Here" Documents
4282             # in Chapter 2: Bits and Pieces
4283             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4284 72         255  
4285 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4286 0         0 $slash = 'm//';
4287             my $here_quote = $1;
4288             my $delimiter = $2;
4289 0 0       0  
4290 0         0 # get here document
4291 0         0 if ($here_script eq '') {
4292             $here_script = CORE::substr $_, pos $_;
4293 0 0       0 $here_script =~ s/.*?\n//oxm;
4294 0         0 }
4295 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4296             push @heredoc, $1 . qq{\n$delimiter\n};
4297             push @heredoc_delimiter, $delimiter;
4298 0         0 }
4299             else {
4300 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4301             }
4302             return $here_quote;
4303             }
4304              
4305 0         0 # <<"HEREDOC"
4306 36         96 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4307 36         79 $slash = 'm//';
4308             my $here_quote = $1;
4309             my $delimiter = $2;
4310 36 50       64  
4311 36         91 # get here document
4312 36         271 if ($here_script eq '') {
4313             $here_script = CORE::substr $_, pos $_;
4314 36 50       201 $here_script =~ s/.*?\n//oxm;
4315 36         507 }
4316 36         113 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4317             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4318             push @heredoc_delimiter, $delimiter;
4319 36         74 }
4320             else {
4321 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4322             }
4323             return $here_quote;
4324             }
4325              
4326 36         146 # <
4327 42         98 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4328 42         88 $slash = 'm//';
4329             my $here_quote = $1;
4330             my $delimiter = $2;
4331 42 50       84  
4332 42         107 # get here document
4333 42         283 if ($here_script eq '') {
4334             $here_script = CORE::substr $_, pos $_;
4335 42 50       314 $here_script =~ s/.*?\n//oxm;
4336 42         583 }
4337 42         143 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4338             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4339             push @heredoc_delimiter, $delimiter;
4340 42         93 }
4341             else {
4342 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4343             }
4344             return $here_quote;
4345             }
4346              
4347 42         172 # <<`HEREDOC`
4348 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4349 0         0 $slash = 'm//';
4350             my $here_quote = $1;
4351             my $delimiter = $2;
4352 0 0       0  
4353 0         0 # get here document
4354 0         0 if ($here_script eq '') {
4355             $here_script = CORE::substr $_, pos $_;
4356 0 0       0 $here_script =~ s/.*?\n//oxm;
4357 0         0 }
4358 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4359             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4360             push @heredoc_delimiter, $delimiter;
4361 0         0 }
4362             else {
4363 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4364             }
4365             return $here_quote;
4366             }
4367              
4368 0         0 # <<= <=> <= < operator
4369             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4370             return $1;
4371             }
4372              
4373 12         63 #
4374             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4375             return $1;
4376             }
4377              
4378             # --- glob
4379              
4380             # avoid "Error: Runtime exception" of perl version 5.005_03
4381 0         0  
4382             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4383             return 'Elatin2::glob("' . $1 . '")';
4384             }
4385 0         0  
4386             # __DATA__
4387             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4388 0         0  
4389             # __END__
4390             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4391              
4392             # \cD Control-D
4393              
4394             # P.68 2.6.8. Other Literal Tokens
4395             # in Chapter 2: Bits and Pieces
4396             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4397              
4398             # P.76 Other Literal Tokens
4399             # in Chapter 2: Bits and Pieces
4400 204         1393 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4401              
4402             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4403 0         0  
4404             # \cZ Control-Z
4405             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4406              
4407             # any operator before div
4408             elsif (/\G (
4409             -- | \+\+ |
4410 0         0 [\)\}\]]
  5081         9961  
4411              
4412             ) /oxgc) { $slash = 'div'; return $1; }
4413              
4414             # yada-yada or triple-dot operator
4415             elsif (/\G (
4416 5081         21920 \.\.\.
  7         20  
4417              
4418             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4419              
4420             # any operator before m//
4421              
4422             # //, //= (defined-or)
4423              
4424             # P.164 Logical Operators
4425             # in Chapter 10: More Control Structures
4426             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4427              
4428             # P.119 C-Style Logical (Short-Circuit) Operators
4429             # in Chapter 3: Unary and Binary Operators
4430             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4431              
4432             # (and so on)
4433              
4434             # ~~
4435              
4436             # P.221 The Smart Match Operator
4437             # in Chapter 15: Smart Matching and given-when
4438             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4439              
4440             # P.112 Smartmatch Operator
4441             # in Chapter 3: Unary and Binary Operators
4442             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4443              
4444             # (and so on)
4445              
4446             elsif (/\G ((?>
4447              
4448             !~~ | !~ | != | ! |
4449             %= | % |
4450             &&= | && | &= | &\.= | &\. | & |
4451             -= | -> | - |
4452             :(?>\s*)= |
4453             : |
4454             <<>> |
4455             <<= | <=> | <= | < |
4456             == | => | =~ | = |
4457             >>= | >> | >= | > |
4458             \*\*= | \*\* | \*= | \* |
4459             \+= | \+ |
4460             \.\. | \.= | \. |
4461             \/\/= | \/\/ |
4462             \/= | \/ |
4463             \? |
4464             \\ |
4465             \^= | \^\.= | \^\. | \^ |
4466             \b x= |
4467             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4468             ~~ | ~\. | ~ |
4469             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4470             \b(?: print )\b |
4471              
4472 7         27 [,;\(\{\[]
  8856         17366  
4473              
4474             )) /oxgc) { $slash = 'm//'; return $1; }
4475 8856         40176  
  15137         28394  
4476             # other any character
4477             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4478              
4479 15137         66078 # system error
4480             else {
4481             die __FILE__, ": Oops, this shouldn't happen!\n";
4482             }
4483             }
4484              
4485 0     1786 0 0 # escape Latin-2 string
4486 1786         3979 sub e_string {
4487             my($string) = @_;
4488 1786         2569 my $e_string = '';
4489              
4490             local $slash = 'm//';
4491              
4492             # P.1024 Appendix W.10 Multibyte Processing
4493             # of ISBN 1-56592-224-7 CJKV Information Processing
4494 1786         2540 # (and so on)
4495              
4496             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4497 1786 100 66     13337  
4498 1786 50       8144 # without { ... }
4499 1769         4208 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4500             if ($string !~ /<
4501             return $string;
4502             }
4503             }
4504 1769         4386  
4505 17 50       59 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          
4506             while ($string !~ /\G \z/oxgc) {
4507             if (0) {
4508             }
4509 190         11160  
4510 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin2::PREMATCH()]}
4511 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4512             $e_string .= q{Elatin2::PREMATCH()};
4513             $slash = 'div';
4514             }
4515              
4516 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin2::MATCH()]}
4517 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4518             $e_string .= q{Elatin2::MATCH()};
4519             $slash = 'div';
4520             }
4521              
4522 0         0 # $', ${'} --> $', ${'}
4523 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4524             $e_string .= $1;
4525             $slash = 'div';
4526             }
4527              
4528 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin2::POSTMATCH()]}
4529 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4530             $e_string .= q{Elatin2::POSTMATCH()};
4531             $slash = 'div';
4532             }
4533              
4534 0         0 # bareword
4535 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4536             $e_string .= $1;
4537             $slash = 'div';
4538             }
4539              
4540 0         0 # $0 --> $0
4541 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4542             $e_string .= $1;
4543             $slash = 'div';
4544 0         0 }
4545 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4546             $e_string .= $1;
4547             $slash = 'div';
4548             }
4549              
4550 0         0 # $$ --> $$
4551 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4552             $e_string .= $1;
4553             $slash = 'div';
4554             }
4555              
4556             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4557 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4558 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4559             $e_string .= e_capture($1);
4560             $slash = 'div';
4561 0         0 }
4562 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4563             $e_string .= e_capture($1);
4564             $slash = 'div';
4565             }
4566              
4567 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4568 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4569             $e_string .= e_capture($1.'->'.$2);
4570             $slash = 'div';
4571             }
4572              
4573 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4574 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4575             $e_string .= e_capture($1.'->'.$2);
4576             $slash = 'div';
4577             }
4578              
4579 0         0 # $$foo
4580 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4581             $e_string .= e_capture($1);
4582             $slash = 'div';
4583             }
4584              
4585 0         0 # ${ foo }
4586 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4587             $e_string .= '${' . $1 . '}';
4588             $slash = 'div';
4589             }
4590              
4591 0         0 # ${ ... }
4592 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4593             $e_string .= e_capture($1);
4594             $slash = 'div';
4595             }
4596              
4597             # variable or function
4598 3         15 # $ @ % & * $ #
4599 7         19 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) {
4600             $e_string .= $1;
4601             $slash = 'div';
4602             }
4603             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4604 7         22 # $ @ # \ ' " / ? ( ) [ ] < >
4605 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4606             $e_string .= $1;
4607             $slash = 'div';
4608             }
4609 0         0  
  0         0  
4610 0         0 # subroutines of package Elatin2
  0         0  
4611 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4612 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4613 0         0 elsif ($string =~ /\G \b Latin2::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4614 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4615 0         0 elsif ($string =~ /\G \b Latin2::eval \b /oxgc) { $e_string .= 'eval Latin2::escape'; $slash = 'm//'; }
  0         0  
4616 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4617 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin2::chop'; $slash = 'm//'; }
  0         0  
4618 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4619 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4620 0         0 elsif ($string =~ /\G \b Latin2::index \b /oxgc) { $e_string .= 'Latin2::index'; $slash = 'm//'; }
  0         0  
4621 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin2::index'; $slash = 'm//'; }
  0         0  
4622 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4623 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4624 0         0 elsif ($string =~ /\G \b Latin2::rindex \b /oxgc) { $e_string .= 'Latin2::rindex'; $slash = 'm//'; }
  0         0  
4625 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin2::rindex'; $slash = 'm//'; }
  0         0  
4626 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::lc'; $slash = 'm//'; }
  0         0  
4627 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::lcfirst'; $slash = 'm//'; }
  0         0  
4628 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::uc'; $slash = 'm//'; }
  0         0  
4629             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::ucfirst'; $slash = 'm//'; }
4630             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::fc'; $slash = 'm//'; }
4631 0         0  
  0         0  
4632 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4633 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4634 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  
4635 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  
4636 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  
4637 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  
4638             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4639 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  
4640 0         0  
  0         0  
4641 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4642 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  
4643 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  
4644 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  
4645 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  
4646             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4647             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4648 0         0  
  0         0  
4649 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4650 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4651 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4652             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4653 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4654 0         0  
  0         0  
4655 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4656 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4657 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::chr'; $slash = 'm//'; }
  0         0  
4658 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4659 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4660 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin2::glob'; $slash = 'm//'; }
  0         0  
4661 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin2::lc_'; $slash = 'm//'; }
  0         0  
4662 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin2::lcfirst_'; $slash = 'm//'; }
  0         0  
4663 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin2::uc_'; $slash = 'm//'; }
  0         0  
4664 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin2::ucfirst_'; $slash = 'm//'; }
  0         0  
4665             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin2::fc_'; $slash = 'm//'; }
4666 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4667 0         0  
  0         0  
4668 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4669 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4670 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin2::chr_'; $slash = 'm//'; }
  0         0  
4671 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin2::glob_'; $slash = 'm//'; }
  0         0  
4674             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4675             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4676 0         0 # split
4677             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4678 0         0 $slash = 'm//';
4679 0         0  
4680 0         0 my $e = '';
4681             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4682             $e .= $1;
4683             }
4684 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4685             # end of split
4686             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin2::split' . $e; }
4687 0         0  
  0         0  
4688             # split scalar value
4689             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin2::split' . $e . e_string($1); next E_STRING_LOOP; }
4690 0         0  
  0         0  
4691 0         0 # split literal space
  0         0  
4692 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4693 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4694 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4695 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4696 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4697 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  
4698 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4699 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4700 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4701 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4702 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4703 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  
4704             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {' '}; next E_STRING_LOOP; }
4705             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin2::split' . $e . qq {" "}; next E_STRING_LOOP; }
4706              
4707 0 0       0 # split qq//
  0         0  
  0         0  
4708             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4709 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4710 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4711 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4712 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4713 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  
4714 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  
4715 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  
4716 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  
4717             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4718 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 * *
4719             }
4720             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4721             }
4722             }
4723              
4724 0 0       0 # split qr//
  0         0  
  0         0  
4725             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4726 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4727 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4728 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4729 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4730 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  
4731 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  
4732 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  
4733 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  
4734 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  
4735             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4736 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 * *
4737             }
4738             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4739             }
4740             }
4741              
4742 0 0       0 # split q//
  0         0  
  0         0  
4743             elsif ($string =~ /\G \b (q) \b /oxgc) {
4744 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4745 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4746 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4747 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4748 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  
4749 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  
4750 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  
4751 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  
4752             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4753 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 * *
4754             }
4755             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4756             }
4757             }
4758              
4759 0 0       0 # split m//
  0         0  
  0         0  
4760             elsif ($string =~ /\G \b (m) \b /oxgc) {
4761 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 # #
4762 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4763 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4764 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4765 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  
4766 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  
4767 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  
4768 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  
4769 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  
4770             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4771 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 * *
4772             }
4773             die __FILE__, ": Search pattern not terminated\n";
4774             }
4775             }
4776              
4777 0         0 # split ''
4778 0         0 elsif ($string =~ /\G (\') /oxgc) {
4779 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4780 0         0 while ($string !~ /\G \z/oxgc) {
4781 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4782 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4783             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4784 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4785             }
4786             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4787             }
4788              
4789 0         0 # split ""
4790 0         0 elsif ($string =~ /\G (\") /oxgc) {
4791 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4792 0         0 while ($string !~ /\G \z/oxgc) {
4793 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4794 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4795             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4796 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4797             }
4798             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4799             }
4800              
4801 0         0 # split //
4802 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4803 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4804 0         0 while ($string !~ /\G \z/oxgc) {
4805 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4806 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4807             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4808 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4809             }
4810             die __FILE__, ": Search pattern not terminated\n";
4811             }
4812             }
4813              
4814 0         0 # qq//
4815 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4816 0         0 my $ope = $1;
4817             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4818             $e_string .= e_qq($ope,$1,$3,$2);
4819 0         0 }
4820 0         0 else {
4821 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4822 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4823 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4824 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4825 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4826 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4827             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4828 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4829             }
4830             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4831             }
4832             }
4833              
4834 0         0 # qx//
4835 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4836 0         0 my $ope = $1;
4837             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4838             $e_string .= e_qq($ope,$1,$3,$2);
4839 0         0 }
4840 0         0 else {
4841 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4842 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4843 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4844 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4845 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4846 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4847 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4848             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4849 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4850             }
4851             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4852             }
4853             }
4854              
4855 0         0 # q//
4856 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4857 0         0 my $ope = $1;
4858             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4859             $e_string .= e_q($ope,$1,$3,$2);
4860 0         0 }
4861 0         0 else {
4862 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4863 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4864 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4865 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4866 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4867 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4868             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4869 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 * *
4870             }
4871             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4872             }
4873             }
4874 0         0  
4875             # ''
4876             elsif ($string =~ /\G (?
4877 0         0  
4878             # ""
4879             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4880 0         0  
4881             # ``
4882             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4883 0         0  
4884             # <<>> (a safer ARGV)
4885             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4886 0         0  
4887             # <<= <=> <= < operator
4888             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4889 0         0  
4890             #
4891             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4892              
4893 0         0 # --- glob
4894             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4895             $e_string .= 'Elatin2::glob("' . $1 . '")';
4896             }
4897              
4898 0         0 # << (bit shift) --- not here document
4899 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4900             $slash = 'm//';
4901             $e_string .= $1;
4902             }
4903              
4904 0         0 # <<~'HEREDOC'
4905 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4906 0         0 $slash = 'm//';
4907             my $here_quote = $1;
4908             my $delimiter = $2;
4909 0 0       0  
4910 0         0 # get here document
4911 0         0 if ($here_script eq '') {
4912             $here_script = CORE::substr $_, pos $_;
4913 0 0       0 $here_script =~ s/.*?\n//oxm;
4914 0         0 }
4915 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4916 0         0 my $heredoc = $1;
4917 0         0 my $indent = $2;
4918 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4919             push @heredoc, $heredoc . qq{\n$delimiter\n};
4920             push @heredoc_delimiter, qq{\\s*$delimiter};
4921 0         0 }
4922             else {
4923 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4924             }
4925             $e_string .= qq{<<'$delimiter'};
4926             }
4927              
4928 0         0 # <<~\HEREDOC
4929 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4930 0         0 $slash = 'm//';
4931             my $here_quote = $1;
4932             my $delimiter = $2;
4933 0 0       0  
4934 0         0 # get here document
4935 0         0 if ($here_script eq '') {
4936             $here_script = CORE::substr $_, pos $_;
4937 0 0       0 $here_script =~ s/.*?\n//oxm;
4938 0         0 }
4939 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4940 0         0 my $heredoc = $1;
4941 0         0 my $indent = $2;
4942 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4943             push @heredoc, $heredoc . qq{\n$delimiter\n};
4944             push @heredoc_delimiter, qq{\\s*$delimiter};
4945 0         0 }
4946             else {
4947 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4948             }
4949             $e_string .= qq{<<\\$delimiter};
4950             }
4951              
4952 0         0 # <<~"HEREDOC"
4953 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4954 0         0 $slash = 'm//';
4955             my $here_quote = $1;
4956             my $delimiter = $2;
4957 0 0       0  
4958 0         0 # get here document
4959 0         0 if ($here_script eq '') {
4960             $here_script = CORE::substr $_, pos $_;
4961 0 0       0 $here_script =~ s/.*?\n//oxm;
4962 0         0 }
4963 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4964 0         0 my $heredoc = $1;
4965 0         0 my $indent = $2;
4966 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4967             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4968             push @heredoc_delimiter, qq{\\s*$delimiter};
4969 0         0 }
4970             else {
4971 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4972             }
4973             $e_string .= qq{<<"$delimiter"};
4974             }
4975              
4976 0         0 # <<~HEREDOC
4977 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4978 0         0 $slash = 'm//';
4979             my $here_quote = $1;
4980             my $delimiter = $2;
4981 0 0       0  
4982 0         0 # get here document
4983 0         0 if ($here_script eq '') {
4984             $here_script = CORE::substr $_, pos $_;
4985 0 0       0 $here_script =~ s/.*?\n//oxm;
4986 0         0 }
4987 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4988 0         0 my $heredoc = $1;
4989 0         0 my $indent = $2;
4990 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4991             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4992             push @heredoc_delimiter, qq{\\s*$delimiter};
4993 0         0 }
4994             else {
4995 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4996             }
4997             $e_string .= qq{<<$delimiter};
4998             }
4999              
5000 0         0 # <<~`HEREDOC`
5001 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
5002 0         0 $slash = 'm//';
5003             my $here_quote = $1;
5004             my $delimiter = $2;
5005 0 0       0  
5006 0         0 # get here document
5007 0         0 if ($here_script eq '') {
5008             $here_script = CORE::substr $_, pos $_;
5009 0 0       0 $here_script =~ s/.*?\n//oxm;
5010 0         0 }
5011 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5012 0         0 my $heredoc = $1;
5013 0         0 my $indent = $2;
5014 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5015             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5016             push @heredoc_delimiter, qq{\\s*$delimiter};
5017 0         0 }
5018             else {
5019 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5020             }
5021             $e_string .= qq{<<`$delimiter`};
5022             }
5023              
5024 0         0 # <<'HEREDOC'
5025 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5026 0         0 $slash = 'm//';
5027             my $here_quote = $1;
5028             my $delimiter = $2;
5029 0 0       0  
5030 0         0 # get here document
5031 0         0 if ($here_script eq '') {
5032             $here_script = CORE::substr $_, pos $_;
5033 0 0       0 $here_script =~ s/.*?\n//oxm;
5034 0         0 }
5035 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5036             push @heredoc, $1 . qq{\n$delimiter\n};
5037             push @heredoc_delimiter, $delimiter;
5038 0         0 }
5039             else {
5040 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5041             }
5042             $e_string .= $here_quote;
5043             }
5044              
5045 0         0 # <<\HEREDOC
5046 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5047 0         0 $slash = 'm//';
5048             my $here_quote = $1;
5049             my $delimiter = $2;
5050 0 0       0  
5051 0         0 # get here document
5052 0         0 if ($here_script eq '') {
5053             $here_script = CORE::substr $_, pos $_;
5054 0 0       0 $here_script =~ s/.*?\n//oxm;
5055 0         0 }
5056 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5057             push @heredoc, $1 . qq{\n$delimiter\n};
5058             push @heredoc_delimiter, $delimiter;
5059 0         0 }
5060             else {
5061 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5062             }
5063             $e_string .= $here_quote;
5064             }
5065              
5066 0         0 # <<"HEREDOC"
5067 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5068 0         0 $slash = 'm//';
5069             my $here_quote = $1;
5070             my $delimiter = $2;
5071 0 0       0  
5072 0         0 # get here document
5073 0         0 if ($here_script eq '') {
5074             $here_script = CORE::substr $_, pos $_;
5075 0 0       0 $here_script =~ s/.*?\n//oxm;
5076 0         0 }
5077 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5078             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5079             push @heredoc_delimiter, $delimiter;
5080 0         0 }
5081             else {
5082 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5083             }
5084             $e_string .= $here_quote;
5085             }
5086              
5087 0         0 # <
5088 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5089 0         0 $slash = 'm//';
5090             my $here_quote = $1;
5091             my $delimiter = $2;
5092 0 0       0  
5093 0         0 # get here document
5094 0         0 if ($here_script eq '') {
5095             $here_script = CORE::substr $_, pos $_;
5096 0 0       0 $here_script =~ s/.*?\n//oxm;
5097 0         0 }
5098 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5099             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5100             push @heredoc_delimiter, $delimiter;
5101 0         0 }
5102             else {
5103 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5104             }
5105             $e_string .= $here_quote;
5106             }
5107              
5108 0         0 # <<`HEREDOC`
5109 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5110 0         0 $slash = 'm//';
5111             my $here_quote = $1;
5112             my $delimiter = $2;
5113 0 0       0  
5114 0         0 # get here document
5115 0         0 if ($here_script eq '') {
5116             $here_script = CORE::substr $_, pos $_;
5117 0 0       0 $here_script =~ s/.*?\n//oxm;
5118 0         0 }
5119 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5120             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5121             push @heredoc_delimiter, $delimiter;
5122 0         0 }
5123             else {
5124 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5125             }
5126             $e_string .= $here_quote;
5127             }
5128              
5129             # any operator before div
5130             elsif ($string =~ /\G (
5131             -- | \+\+ |
5132 0         0 [\)\}\]]
  18         31  
5133              
5134             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5135              
5136             # yada-yada or triple-dot operator
5137             elsif ($string =~ /\G (
5138 18         53 \.\.\.
  0         0  
5139              
5140             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5141              
5142             # any operator before m//
5143             elsif ($string =~ /\G ((?>
5144              
5145             !~~ | !~ | != | ! |
5146             %= | % |
5147             &&= | && | &= | &\.= | &\. | & |
5148             -= | -> | - |
5149             :(?>\s*)= |
5150             : |
5151             <<>> |
5152             <<= | <=> | <= | < |
5153             == | => | =~ | = |
5154             >>= | >> | >= | > |
5155             \*\*= | \*\* | \*= | \* |
5156             \+= | \+ |
5157             \.\. | \.= | \. |
5158             \/\/= | \/\/ |
5159             \/= | \/ |
5160             \? |
5161             \\ |
5162             \^= | \^\.= | \^\. | \^ |
5163             \b x= |
5164             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5165             ~~ | ~\. | ~ |
5166             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5167             \b(?: print )\b |
5168              
5169 0         0 [,;\(\{\[]
  31         55  
5170              
5171             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5172 31         108  
5173             # other any character
5174             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5175              
5176 131         334 # system error
5177             else {
5178             die __FILE__, ": Oops, this shouldn't happen!\n";
5179             }
5180 0         0 }
5181              
5182             return $e_string;
5183             }
5184              
5185             #
5186             # character class
5187 17     1919 0 71 #
5188             sub character_class {
5189 1919 100       3532 my($char,$modifier) = @_;
5190 1919 100       3025  
5191 52         102 if ($char eq '.') {
5192             if ($modifier =~ /s/) {
5193             return '${Elatin2::dot_s}';
5194 17         41 }
5195             else {
5196             return '${Elatin2::dot}';
5197             }
5198 35         79 }
5199             else {
5200             return Elatin2::classic_character_class($char);
5201             }
5202             }
5203              
5204             #
5205             # escape capture ($1, $2, $3, ...)
5206             #
5207 1867     212 0 3433 sub e_capture {
5208              
5209             return join '', '${', $_[0], '}';
5210             }
5211              
5212             #
5213             # escape transliteration (tr/// or y///)
5214 212     3 0 948 #
5215 3         20 sub e_tr {
5216 3   50     5 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5217             my $e_tr = '';
5218 3         8 $modifier ||= '';
5219              
5220             $slash = 'div';
5221 3         4  
5222             # quote character class 1
5223             $charclass = q_tr($charclass);
5224 3         8  
5225             # quote character class 2
5226             $charclass2 = q_tr($charclass2);
5227 3 50       6  
5228 3 0       10 # /b /B modifier
5229 0         0 if ($modifier =~ tr/bB//d) {
5230             if ($variable eq '') {
5231             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5232 0         0 }
5233             else {
5234             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5235             }
5236 0 100       0 }
5237 3         7 else {
5238             if ($variable eq '') {
5239             $e_tr = qq{Elatin2::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5240 2         8 }
5241             else {
5242             $e_tr = qq{Elatin2::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5243             }
5244             }
5245 1         5  
5246 3         5 # clear tr/// variable
5247             $tr_variable = '';
5248 3         4 $bind_operator = '';
5249              
5250             return $e_tr;
5251             }
5252              
5253             #
5254             # quote for escape transliteration (tr/// or y///)
5255 3     6 0 16 #
5256             sub q_tr {
5257             my($charclass) = @_;
5258 6 50       9  
    0          
    0          
    0          
    0          
    0          
5259 6         13 # quote character class
5260             if ($charclass !~ /'/oxms) {
5261             return e_q('', "'", "'", $charclass); # --> q' '
5262 6         12 }
5263             elsif ($charclass !~ /\//oxms) {
5264             return e_q('q', '/', '/', $charclass); # --> q/ /
5265 0         0 }
5266             elsif ($charclass !~ /\#/oxms) {
5267             return e_q('q', '#', '#', $charclass); # --> q# #
5268 0         0 }
5269             elsif ($charclass !~ /[\<\>]/oxms) {
5270             return e_q('q', '<', '>', $charclass); # --> q< >
5271 0         0 }
5272             elsif ($charclass !~ /[\(\)]/oxms) {
5273             return e_q('q', '(', ')', $charclass); # --> q( )
5274 0         0 }
5275             elsif ($charclass !~ /[\{\}]/oxms) {
5276             return e_q('q', '{', '}', $charclass); # --> q{ }
5277 0         0 }
5278 0 0       0 else {
5279 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5280             if ($charclass !~ /\Q$char\E/xms) {
5281             return e_q('q', $char, $char, $charclass);
5282             }
5283             }
5284 0         0 }
5285              
5286             return e_q('q', '{', '}', $charclass);
5287             }
5288              
5289             #
5290             # escape q string (q//, '')
5291 0     1264 0 0 #
5292             sub e_q {
5293 1264         2983 my($ope,$delimiter,$end_delimiter,$string) = @_;
5294              
5295 1264         1989 $slash = 'div';
5296              
5297             return join '', $ope, $delimiter, $string, $end_delimiter;
5298             }
5299              
5300             #
5301             # escape qq string (qq//, "", qx//, ``)
5302 1264     4086 0 8214 #
5303             sub e_qq {
5304 4086         10347 my($ope,$delimiter,$end_delimiter,$string) = @_;
5305              
5306 4086         5298 $slash = 'div';
5307 4086         5075  
5308             my $left_e = 0;
5309             my $right_e = 0;
5310 4086         4529  
5311             # split regexp
5312             my @char = $string =~ /\G((?>
5313             [^\\\$] |
5314             \\x\{ (?>[0-9A-Fa-f]+) \} |
5315             \\o\{ (?>[0-7]+) \} |
5316             \\N\{ (?>[^0-9\}][^\}]*) \} |
5317             \\ $q_char |
5318             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5319             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5320             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5321             \$ (?>\s* [0-9]+) |
5322             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5323             \$ \$ (?![\w\{]) |
5324             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5325             $q_char
5326 4086         137387 ))/oxmsg;
5327              
5328             for (my $i=0; $i <= $#char; $i++) {
5329 4086 50 33     12334  
    50 33        
    100          
    100          
    50          
5330 113901         378362 # "\L\u" --> "\u\L"
5331             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5332             @char[$i,$i+1] = @char[$i+1,$i];
5333             }
5334              
5335 0         0 # "\U\l" --> "\l\U"
5336             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5337             @char[$i,$i+1] = @char[$i+1,$i];
5338             }
5339              
5340 0         0 # octal escape sequence
5341             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5342             $char[$i] = Elatin2::octchr($1);
5343             }
5344              
5345 1         4 # hexadecimal escape sequence
5346             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5347             $char[$i] = Elatin2::hexchr($1);
5348             }
5349              
5350 1         5 # \N{CHARNAME} --> N{CHARNAME}
5351             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5352             $char[$i] = $1;
5353 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          
5354              
5355             if (0) {
5356             }
5357              
5358             # \F
5359             #
5360             # P.69 Table 2-6. Translation escapes
5361             # in Chapter 2: Bits and Pieces
5362             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5363             # (and so on)
5364 113901         931125  
5365 0 50       0 # \u \l \U \L \F \Q \E
5366 484         1038 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5367             if ($right_e < $left_e) {
5368             $char[$i] = '\\' . $char[$i];
5369             }
5370             }
5371             elsif ($char[$i] eq '\u') {
5372              
5373             # "STRING @{[ LIST EXPR ]} MORE STRING"
5374              
5375             # P.257 Other Tricks You Can Do with Hard References
5376             # in Chapter 8: References
5377             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5378              
5379             # P.353 Other Tricks You Can Do with Hard References
5380             # in Chapter 8: References
5381             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5382              
5383 0         0 # (and so on)
5384 0         0  
5385             $char[$i] = '@{[Elatin2::ucfirst qq<';
5386             $left_e++;
5387 0         0 }
5388 0         0 elsif ($char[$i] eq '\l') {
5389             $char[$i] = '@{[Elatin2::lcfirst qq<';
5390             $left_e++;
5391 0         0 }
5392 0         0 elsif ($char[$i] eq '\U') {
5393             $char[$i] = '@{[Elatin2::uc qq<';
5394             $left_e++;
5395 0         0 }
5396 0         0 elsif ($char[$i] eq '\L') {
5397             $char[$i] = '@{[Elatin2::lc qq<';
5398             $left_e++;
5399 0         0 }
5400 24         35 elsif ($char[$i] eq '\F') {
5401             $char[$i] = '@{[Elatin2::fc qq<';
5402             $left_e++;
5403 24         45 }
5404 0         0 elsif ($char[$i] eq '\Q') {
5405             $char[$i] = '@{[CORE::quotemeta qq<';
5406             $left_e++;
5407 0 50       0 }
5408 24         32 elsif ($char[$i] eq '\E') {
5409 24         35 if ($right_e < $left_e) {
5410             $char[$i] = '>]}';
5411             $right_e++;
5412 24         42 }
5413             else {
5414             $char[$i] = '';
5415             }
5416 0         0 }
5417 0 0       0 elsif ($char[$i] eq '\Q') {
5418 0         0 while (1) {
5419             if (++$i > $#char) {
5420 0 0       0 last;
5421 0         0 }
5422             if ($char[$i] eq '\E') {
5423             last;
5424             }
5425             }
5426             }
5427             elsif ($char[$i] eq '\E') {
5428             }
5429              
5430             # $0 --> $0
5431             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5432             }
5433             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5434             }
5435              
5436             # $$ --> $$
5437             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5438             }
5439              
5440             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5441 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5442             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5443             $char[$i] = e_capture($1);
5444 205         445 }
5445             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5446             $char[$i] = e_capture($1);
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_bracket)*? \] ) \z/oxms) {
5451             $char[$i] = e_capture($1.'->'.$2);
5452             }
5453              
5454 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5455             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5456             $char[$i] = e_capture($1.'->'.$2);
5457             }
5458              
5459 0         0 # $$foo
5460             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5461             $char[$i] = e_capture($1);
5462             }
5463              
5464 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
5465             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5466             $char[$i] = '@{[Elatin2::PREMATCH()]}';
5467             }
5468              
5469 44         124 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
5470             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5471             $char[$i] = '@{[Elatin2::MATCH()]}';
5472             }
5473              
5474 45         125 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
5475             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5476             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
5477             }
5478              
5479             # ${ foo } --> ${ foo }
5480             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5481             }
5482              
5483 33         94 # ${ ... }
5484             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5485             $char[$i] = e_capture($1);
5486             }
5487             }
5488 0 50       0  
5489 4086         7413 # return string
5490             if ($left_e > $right_e) {
5491 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5492             }
5493             return join '', $ope, $delimiter, @char, $end_delimiter;
5494             }
5495              
5496             #
5497             # escape qw string (qw//)
5498 4086     16 0 36384 #
5499             sub e_qw {
5500 16         663 my($ope,$delimiter,$end_delimiter,$string) = @_;
5501              
5502             $slash = 'div';
5503 16         56  
  16         234  
5504 483 50       788 # choice again delimiter
    0          
    0          
    0          
    0          
5505 16         101 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5506             if (not $octet{$end_delimiter}) {
5507             return join '', $ope, $delimiter, $string, $end_delimiter;
5508 16         158 }
5509             elsif (not $octet{')'}) {
5510             return join '', $ope, '(', $string, ')';
5511 0         0 }
5512             elsif (not $octet{'}'}) {
5513             return join '', $ope, '{', $string, '}';
5514 0         0 }
5515             elsif (not $octet{']'}) {
5516             return join '', $ope, '[', $string, ']';
5517 0         0 }
5518             elsif (not $octet{'>'}) {
5519             return join '', $ope, '<', $string, '>';
5520 0         0 }
5521 0 0       0 else {
5522 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5523             if (not $octet{$char}) {
5524             return join '', $ope, $char, $string, $char;
5525             }
5526             }
5527             }
5528 0         0  
5529 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5530 0         0 my @string = CORE::split(/\s+/, $string);
5531 0         0 for my $string (@string) {
5532 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5533 0         0 for my $octet (@octet) {
5534             if ($octet =~ /\A (['\\]) \z/oxms) {
5535             $octet = '\\' . $1;
5536 0         0 }
5537             }
5538 0         0 $string = join '', @octet;
  0         0  
5539             }
5540             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5541             }
5542              
5543             #
5544             # escape here document (<<"HEREDOC", <
5545 0     93 0 0 #
5546             sub e_heredoc {
5547 93         231 my($string) = @_;
5548              
5549 93         155 $slash = 'm//';
5550              
5551 93         298 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5552 93         141  
5553             my $left_e = 0;
5554             my $right_e = 0;
5555 93         121  
5556             # split regexp
5557             my @char = $string =~ /\G((?>
5558             [^\\\$] |
5559             \\x\{ (?>[0-9A-Fa-f]+) \} |
5560             \\o\{ (?>[0-7]+) \} |
5561             \\N\{ (?>[^0-9\}][^\}]*) \} |
5562             \\ $q_char |
5563             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5564             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5565             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5566             \$ (?>\s* [0-9]+) |
5567             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5568             \$ \$ (?![\w\{]) |
5569             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5570             $q_char
5571 93         8122 ))/oxmsg;
5572              
5573             for (my $i=0; $i <= $#char; $i++) {
5574 93 50 33     397  
    50 33        
    100          
    100          
    50          
5575 3177         9382 # "\L\u" --> "\u\L"
5576             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5577             @char[$i,$i+1] = @char[$i+1,$i];
5578             }
5579              
5580 0         0 # "\U\l" --> "\l\U"
5581             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5582             @char[$i,$i+1] = @char[$i+1,$i];
5583             }
5584              
5585 0         0 # octal escape sequence
5586             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5587             $char[$i] = Elatin2::octchr($1);
5588             }
5589              
5590 1         4 # hexadecimal escape sequence
5591             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5592             $char[$i] = Elatin2::hexchr($1);
5593             }
5594              
5595 1         3 # \N{CHARNAME} --> N{CHARNAME}
5596             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5597             $char[$i] = $1;
5598 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          
5599              
5600             if (0) {
5601             }
5602 3177         25306  
5603 0 0       0 # \u \l \U \L \F \Q \E
5604 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5605             if ($right_e < $left_e) {
5606             $char[$i] = '\\' . $char[$i];
5607             }
5608 0         0 }
5609 0         0 elsif ($char[$i] eq '\u') {
5610             $char[$i] = '@{[Elatin2::ucfirst qq<';
5611             $left_e++;
5612 0         0 }
5613 0         0 elsif ($char[$i] eq '\l') {
5614             $char[$i] = '@{[Elatin2::lcfirst qq<';
5615             $left_e++;
5616 0         0 }
5617 0         0 elsif ($char[$i] eq '\U') {
5618             $char[$i] = '@{[Elatin2::uc qq<';
5619             $left_e++;
5620 0         0 }
5621 0         0 elsif ($char[$i] eq '\L') {
5622             $char[$i] = '@{[Elatin2::lc qq<';
5623             $left_e++;
5624 0         0 }
5625 0         0 elsif ($char[$i] eq '\F') {
5626             $char[$i] = '@{[Elatin2::fc qq<';
5627             $left_e++;
5628 0         0 }
5629 0         0 elsif ($char[$i] eq '\Q') {
5630             $char[$i] = '@{[CORE::quotemeta qq<';
5631             $left_e++;
5632 0 0       0 }
5633 0         0 elsif ($char[$i] eq '\E') {
5634 0         0 if ($right_e < $left_e) {
5635             $char[$i] = '>]}';
5636             $right_e++;
5637 0         0 }
5638             else {
5639             $char[$i] = '';
5640             }
5641 0         0 }
5642 0 0       0 elsif ($char[$i] eq '\Q') {
5643 0         0 while (1) {
5644             if (++$i > $#char) {
5645 0 0       0 last;
5646 0         0 }
5647             if ($char[$i] eq '\E') {
5648             last;
5649             }
5650             }
5651             }
5652             elsif ($char[$i] eq '\E') {
5653             }
5654              
5655             # $0 --> $0
5656             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5657             }
5658             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5659             }
5660              
5661             # $$ --> $$
5662             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5663             }
5664              
5665             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5666 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5667             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5668             $char[$i] = e_capture($1);
5669 0         0 }
5670             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5671             $char[$i] = e_capture($1);
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_bracket)*? \] ) \z/oxms) {
5676             $char[$i] = e_capture($1.'->'.$2);
5677             }
5678              
5679 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5680             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5681             $char[$i] = e_capture($1.'->'.$2);
5682             }
5683              
5684 0         0 # $$foo
5685             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5686             $char[$i] = e_capture($1);
5687             }
5688              
5689 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
5690             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5691             $char[$i] = '@{[Elatin2::PREMATCH()]}';
5692             }
5693              
5694 8         48 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
5695             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5696             $char[$i] = '@{[Elatin2::MATCH()]}';
5697             }
5698              
5699 8         51 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
5700             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5701             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
5702             }
5703              
5704             # ${ foo } --> ${ foo }
5705             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5706             }
5707              
5708 6         31 # ${ ... }
5709             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5710             $char[$i] = e_capture($1);
5711             }
5712             }
5713 0 50       0  
5714 93         193 # return string
5715             if ($left_e > $right_e) {
5716 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5717             }
5718             return join '', @char;
5719             }
5720              
5721             #
5722             # escape regexp (m//, qr//)
5723 93     652 0 689 #
5724 652   100     2750 sub e_qr {
5725             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5726 652         2761 $modifier ||= '';
5727 652 50       1191  
5728 652         1573 $modifier =~ tr/p//d;
5729 0         0 if ($modifier =~ /([adlu])/oxms) {
5730 0 0       0 my $line = 0;
5731 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5732 0         0 if ($filename ne __FILE__) {
5733             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5734             last;
5735 0         0 }
5736             }
5737             die qq{Unsupported modifier "$1" used at line $line.\n};
5738 0         0 }
5739              
5740             $slash = 'div';
5741 652 100       1082  
    100          
5742 652         1972 # literal null string pattern
5743 8         13 if ($string eq '') {
5744 8         11 $modifier =~ tr/bB//d;
5745             $modifier =~ tr/i//d;
5746             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5747             }
5748              
5749             # /b /B modifier
5750             elsif ($modifier =~ tr/bB//d) {
5751 8 50       38  
5752 2         6 # choice again delimiter
5753 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5754 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5755 0         0 my %octet = map {$_ => 1} @char;
5756 0         0 if (not $octet{')'}) {
5757             $delimiter = '(';
5758             $end_delimiter = ')';
5759 0         0 }
5760 0         0 elsif (not $octet{'}'}) {
5761             $delimiter = '{';
5762             $end_delimiter = '}';
5763 0         0 }
5764 0         0 elsif (not $octet{']'}) {
5765             $delimiter = '[';
5766             $end_delimiter = ']';
5767 0         0 }
5768 0         0 elsif (not $octet{'>'}) {
5769             $delimiter = '<';
5770             $end_delimiter = '>';
5771 0         0 }
5772 0 0       0 else {
5773 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5774 0         0 if (not $octet{$char}) {
5775 0         0 $delimiter = $char;
5776             $end_delimiter = $char;
5777             last;
5778             }
5779             }
5780             }
5781 0 50 33     0 }
5782 2         13  
5783             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5784             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5785 0         0 }
5786             else {
5787             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5788             }
5789 2 100       12 }
5790 642         1460  
5791             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5792             my $metachar = qr/[\@\\|[\]{^]/oxms;
5793 642         2528  
5794             # split regexp
5795             my @char = $string =~ /\G((?>
5796             [^\\\$\@\[\(] |
5797             \\x (?>[0-9A-Fa-f]{1,2}) |
5798             \\ (?>[0-7]{2,3}) |
5799             \\c [\x40-\x5F] |
5800             \\x\{ (?>[0-9A-Fa-f]+) \} |
5801             \\o\{ (?>[0-7]+) \} |
5802             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5803             \\ $q_char |
5804             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5805             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5806             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5807             [\$\@] $qq_variable |
5808             \$ (?>\s* [0-9]+) |
5809             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5810             \$ \$ (?![\w\{]) |
5811             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5812             \[\^ |
5813             \[\: (?>[a-z]+) :\] |
5814             \[\:\^ (?>[a-z]+) :\] |
5815             \(\? |
5816             $q_char
5817             ))/oxmsg;
5818 642 50       87727  
5819 642         3092 # choice again delimiter
  0         0  
5820 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5821 0         0 my %octet = map {$_ => 1} @char;
5822 0         0 if (not $octet{')'}) {
5823             $delimiter = '(';
5824             $end_delimiter = ')';
5825 0         0 }
5826 0         0 elsif (not $octet{'}'}) {
5827             $delimiter = '{';
5828             $end_delimiter = '}';
5829 0         0 }
5830 0         0 elsif (not $octet{']'}) {
5831             $delimiter = '[';
5832             $end_delimiter = ']';
5833 0         0 }
5834 0         0 elsif (not $octet{'>'}) {
5835             $delimiter = '<';
5836             $end_delimiter = '>';
5837 0         0 }
5838 0 0       0 else {
5839 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5840 0         0 if (not $octet{$char}) {
5841 0         0 $delimiter = $char;
5842             $end_delimiter = $char;
5843             last;
5844             }
5845             }
5846             }
5847 0         0 }
5848 642         1128  
5849 642         916 my $left_e = 0;
5850             my $right_e = 0;
5851             for (my $i=0; $i <= $#char; $i++) {
5852 642 50 66     1721  
    50 66        
    100          
    100          
    100          
    100          
5853 1872         9631 # "\L\u" --> "\u\L"
5854             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5855             @char[$i,$i+1] = @char[$i+1,$i];
5856             }
5857              
5858 0         0 # "\U\l" --> "\l\U"
5859             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5860             @char[$i,$i+1] = @char[$i+1,$i];
5861             }
5862              
5863 0         0 # octal escape sequence
5864             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5865             $char[$i] = Elatin2::octchr($1);
5866             }
5867              
5868 1         4 # hexadecimal escape sequence
5869             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5870             $char[$i] = Elatin2::hexchr($1);
5871             }
5872              
5873             # \b{...} --> b\{...}
5874             # \B{...} --> B\{...}
5875             # \N{CHARNAME} --> N\{CHARNAME}
5876             # \p{PROPERTY} --> p\{PROPERTY}
5877 1         4 # \P{PROPERTY} --> P\{PROPERTY}
5878             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5879             $char[$i] = $1 . '\\' . $2;
5880             }
5881              
5882 6         19 # \p, \P, \X --> p, P, X
5883             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5884             $char[$i] = $1;
5885 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          
5886              
5887             if (0) {
5888             }
5889 1872         6590  
5890 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5891 6         90 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5892             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)) {
5893             $char[$i] .= join '', splice @char, $i+1, 3;
5894 0         0 }
5895             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)) {
5896             $char[$i] .= join '', splice @char, $i+1, 2;
5897 0         0 }
5898             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)) {
5899             $char[$i] .= join '', splice @char, $i+1, 1;
5900             }
5901             }
5902              
5903 0         0 # open character class [...]
5904             elsif ($char[$i] eq '[') {
5905             my $left = $i;
5906              
5907             # [] make die "Unmatched [] in regexp ...\n"
5908 328 100       465 # (and so on)
5909 328         1429  
5910             if ($char[$i+1] eq ']') {
5911             $i++;
5912 3         5 }
5913 328 50       459  
5914 1379         2057 while (1) {
5915             if (++$i > $#char) {
5916 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5917 1379         2050 }
5918             if ($char[$i] eq ']') {
5919             my $right = $i;
5920 328 100       435  
5921 328         1753 # [...]
  30         63  
5922             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5923             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);
5924 90         148 }
5925             else {
5926             splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
5927 298         6681 }
5928 328         646  
5929             $i = $left;
5930             last;
5931             }
5932             }
5933             }
5934              
5935 328         872 # open character class [^...]
5936             elsif ($char[$i] eq '[^') {
5937             my $left = $i;
5938              
5939             # [^] make die "Unmatched [] in regexp ...\n"
5940 74 100       149 # (and so on)
5941 74         158  
5942             if ($char[$i+1] eq ']') {
5943             $i++;
5944 4         6 }
5945 74 50       141  
5946 272         425 while (1) {
5947             if (++$i > $#char) {
5948 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5949 272         1964 }
5950             if ($char[$i] eq ']') {
5951             my $right = $i;
5952 74 100       90  
5953 74         351 # [^...]
  30         71  
5954             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5955             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);
5956 90         142 }
5957             else {
5958             splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5959 44         189 }
5960 74         129  
5961             $i = $left;
5962             last;
5963             }
5964             }
5965             }
5966              
5967 74         278 # rewrite character class or escape character
5968             elsif (my $char = character_class($char[$i],$modifier)) {
5969             $char[$i] = $char;
5970             }
5971              
5972 139 50       353 # /i modifier
5973 20         43 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
5974             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
5975             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
5976 20         43 }
5977             else {
5978             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
5979             }
5980             }
5981              
5982 0 50       0 # \u \l \U \L \F \Q \E
5983 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5984             if ($right_e < $left_e) {
5985             $char[$i] = '\\' . $char[$i];
5986             }
5987 0         0 }
5988 0         0 elsif ($char[$i] eq '\u') {
5989             $char[$i] = '@{[Elatin2::ucfirst qq<';
5990             $left_e++;
5991 0         0 }
5992 0         0 elsif ($char[$i] eq '\l') {
5993             $char[$i] = '@{[Elatin2::lcfirst qq<';
5994             $left_e++;
5995 0         0 }
5996 1         3 elsif ($char[$i] eq '\U') {
5997             $char[$i] = '@{[Elatin2::uc qq<';
5998             $left_e++;
5999 1         3 }
6000 1         6 elsif ($char[$i] eq '\L') {
6001             $char[$i] = '@{[Elatin2::lc qq<';
6002             $left_e++;
6003 1         4 }
6004 18         32 elsif ($char[$i] eq '\F') {
6005             $char[$i] = '@{[Elatin2::fc qq<';
6006             $left_e++;
6007 18         39 }
6008 1         3 elsif ($char[$i] eq '\Q') {
6009             $char[$i] = '@{[CORE::quotemeta qq<';
6010             $left_e++;
6011 1 50       3 }
6012 21         49 elsif ($char[$i] eq '\E') {
6013 21         30 if ($right_e < $left_e) {
6014             $char[$i] = '>]}';
6015             $right_e++;
6016 21         45 }
6017             else {
6018             $char[$i] = '';
6019             }
6020 0         0 }
6021 0 0       0 elsif ($char[$i] eq '\Q') {
6022 0         0 while (1) {
6023             if (++$i > $#char) {
6024 0 0       0 last;
6025 0         0 }
6026             if ($char[$i] eq '\E') {
6027             last;
6028             }
6029             }
6030             }
6031             elsif ($char[$i] eq '\E') {
6032             }
6033              
6034 0 0       0 # $0 --> $0
6035 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6036             if ($ignorecase) {
6037             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6038             }
6039 0 0       0 }
6040 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6041             if ($ignorecase) {
6042             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6043             }
6044             }
6045              
6046             # $$ --> $$
6047             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6048             }
6049              
6050             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6051 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6052 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6053 0         0 $char[$i] = e_capture($1);
6054             if ($ignorecase) {
6055             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6056             }
6057 0         0 }
6058 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6059 0         0 $char[$i] = e_capture($1);
6060             if ($ignorecase) {
6061             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6062             }
6063             }
6064              
6065 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6066 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) {
6067 0         0 $char[$i] = e_capture($1.'->'.$2);
6068             if ($ignorecase) {
6069             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6070             }
6071             }
6072              
6073 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6074 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) {
6075 0         0 $char[$i] = e_capture($1.'->'.$2);
6076             if ($ignorecase) {
6077             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6078             }
6079             }
6080              
6081 0         0 # $$foo
6082 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6083 0         0 $char[$i] = e_capture($1);
6084             if ($ignorecase) {
6085             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6086             }
6087             }
6088              
6089 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
6090 8         24 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6091             if ($ignorecase) {
6092             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::PREMATCH())]}';
6093 0         0 }
6094             else {
6095             $char[$i] = '@{[Elatin2::PREMATCH()]}';
6096             }
6097             }
6098              
6099 8 50       24 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
6100 8         22 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6101             if ($ignorecase) {
6102             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::MATCH())]}';
6103 0         0 }
6104             else {
6105             $char[$i] = '@{[Elatin2::MATCH()]}';
6106             }
6107             }
6108              
6109 8 50       22 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
6110 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6111             if ($ignorecase) {
6112             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::POSTMATCH())]}';
6113 0         0 }
6114             else {
6115             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
6116             }
6117             }
6118              
6119 6 0       17 # ${ foo }
6120 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) {
6121             if ($ignorecase) {
6122             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6123             }
6124             }
6125              
6126 0         0 # ${ ... }
6127 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6128 0         0 $char[$i] = e_capture($1);
6129             if ($ignorecase) {
6130             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6131             }
6132             }
6133              
6134 0         0 # $scalar or @array
6135 21 100       54 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6136 21         109 $char[$i] = e_string($char[$i]);
6137             if ($ignorecase) {
6138             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6139             }
6140             }
6141              
6142 11 100 33     34 # quote character before ? + * {
    50          
6143             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6144             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6145 138         1093 }
6146 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6147 0         0 my $char = $char[$i-1];
6148             if ($char[$i] eq '{') {
6149             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6150 0         0 }
6151             else {
6152             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6153             }
6154 0         0 }
6155             else {
6156             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6157             }
6158             }
6159             }
6160 127         502  
6161 642 50       1303 # make regexp string
6162 642 0 0     1393 $modifier =~ tr/i//d;
6163 0         0 if ($left_e > $right_e) {
6164             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6165             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6166 0         0 }
6167             else {
6168             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6169 0 50 33     0 }
6170 642         3459 }
6171             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6172             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6173 0         0 }
6174             else {
6175             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6176             }
6177             }
6178              
6179             #
6180             # double quote stuff
6181 642     180 0 5960 #
6182             sub qq_stuff {
6183             my($delimiter,$end_delimiter,$stuff) = @_;
6184 180 100       259  
6185 180         358 # scalar variable or array variable
6186             if ($stuff =~ /\A [\$\@] /oxms) {
6187             return $stuff;
6188             }
6189 100         332  
  80         173  
6190 80         222 # quote by delimiter
6191 80 50       245 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6192 80 50       129 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6193 80 50       122 next if $char eq $delimiter;
6194 80         131 next if $char eq $end_delimiter;
6195             if (not $octet{$char}) {
6196             return join '', 'qq', $char, $stuff, $char;
6197 80         295 }
6198             }
6199             return join '', 'qq', '<', $stuff, '>';
6200             }
6201              
6202             #
6203             # escape regexp (m'', qr'', and m''b, qr''b)
6204 0     10 0 0 #
6205 10   50     50 sub e_qr_q {
6206             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6207 10         50 $modifier ||= '';
6208 10 50       12  
6209 10         24 $modifier =~ tr/p//d;
6210 0         0 if ($modifier =~ /([adlu])/oxms) {
6211 0 0       0 my $line = 0;
6212 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6213 0         0 if ($filename ne __FILE__) {
6214             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6215             last;
6216 0         0 }
6217             }
6218             die qq{Unsupported modifier "$1" used at line $line.\n};
6219 0         0 }
6220              
6221             $slash = 'div';
6222 10 100       14  
    50          
6223 10         27 # literal null string pattern
6224 8         9 if ($string eq '') {
6225 8         11 $modifier =~ tr/bB//d;
6226             $modifier =~ tr/i//d;
6227             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6228             }
6229              
6230 8         40 # with /b /B modifier
6231             elsif ($modifier =~ tr/bB//d) {
6232             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6233             }
6234              
6235 0         0 # without /b /B modifier
6236             else {
6237             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6238             }
6239             }
6240              
6241             #
6242             # escape regexp (m'', qr'')
6243 2     2 0 8 #
6244             sub e_qr_qt {
6245 2 50       8 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6246              
6247             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6248 2         8  
6249             # split regexp
6250             my @char = $string =~ /\G((?>
6251             [^\\\[\$\@\/] |
6252             [\x00-\xFF] |
6253             \[\^ |
6254             \[\: (?>[a-z]+) \:\] |
6255             \[\:\^ (?>[a-z]+) \:\] |
6256             [\$\@\/] |
6257             \\ (?:$q_char) |
6258             (?:$q_char)
6259             ))/oxmsg;
6260 2         171  
6261 2 50 33     12 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6262             for (my $i=0; $i <= $#char; $i++) {
6263             if (0) {
6264             }
6265 2         20  
6266 0         0 # open character class [...]
6267 0 0       0 elsif ($char[$i] eq '[') {
6268 0         0 my $left = $i;
6269             if ($char[$i+1] eq ']') {
6270 0         0 $i++;
6271 0 0       0 }
6272 0         0 while (1) {
6273             if (++$i > $#char) {
6274 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6275 0         0 }
6276             if ($char[$i] eq ']') {
6277             my $right = $i;
6278 0         0  
6279             # [...]
6280 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
6281 0         0  
6282             $i = $left;
6283             last;
6284             }
6285             }
6286             }
6287              
6288 0         0 # open character class [^...]
6289 0 0       0 elsif ($char[$i] eq '[^') {
6290 0         0 my $left = $i;
6291             if ($char[$i+1] eq ']') {
6292 0         0 $i++;
6293 0 0       0 }
6294 0         0 while (1) {
6295             if (++$i > $#char) {
6296 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6297 0         0 }
6298             if ($char[$i] eq ']') {
6299             my $right = $i;
6300 0         0  
6301             # [^...]
6302 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6303 0         0  
6304             $i = $left;
6305             last;
6306             }
6307             }
6308             }
6309              
6310 0         0 # escape $ @ / and \
6311             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6312             $char[$i] = '\\' . $char[$i];
6313             }
6314              
6315 0         0 # rewrite character class or escape character
6316             elsif (my $char = character_class($char[$i],$modifier)) {
6317             $char[$i] = $char;
6318             }
6319              
6320 0 0       0 # /i modifier
6321 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
6322             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
6323             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
6324 0         0 }
6325             else {
6326             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
6327             }
6328             }
6329              
6330 0 0       0 # quote character before ? + * {
6331             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6332             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6333 0         0 }
6334             else {
6335             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6336             }
6337             }
6338 0         0 }
6339 2         6  
6340             $delimiter = '/';
6341 2         3 $end_delimiter = '/';
6342 2         5  
6343             $modifier =~ tr/i//d;
6344             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6345             }
6346              
6347             #
6348             # escape regexp (m''b, qr''b)
6349 2     0 0 16 #
6350             sub e_qr_qb {
6351             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6352 0         0  
6353             # split regexp
6354             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6355 0         0  
6356 0 0       0 # unescape character
    0          
6357             for (my $i=0; $i <= $#char; $i++) {
6358             if (0) {
6359             }
6360 0         0  
6361             # remain \\
6362             elsif ($char[$i] eq '\\\\') {
6363             }
6364              
6365 0         0 # escape $ @ / and \
6366             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6367             $char[$i] = '\\' . $char[$i];
6368             }
6369 0         0 }
6370 0         0  
6371 0         0 $delimiter = '/';
6372             $end_delimiter = '/';
6373             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6374             }
6375              
6376             #
6377             # escape regexp (s/here//)
6378 0     76 0 0 #
6379 76   100     244 sub e_s1 {
6380             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6381 76         330 $modifier ||= '';
6382 76 50       119  
6383 76         200 $modifier =~ tr/p//d;
6384 0         0 if ($modifier =~ /([adlu])/oxms) {
6385 0 0       0 my $line = 0;
6386 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6387 0         0 if ($filename ne __FILE__) {
6388             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6389             last;
6390 0         0 }
6391             }
6392             die qq{Unsupported modifier "$1" used at line $line.\n};
6393 0         0 }
6394              
6395             $slash = 'div';
6396 76 100       191  
    50          
6397 76         264 # literal null string pattern
6398 8         14 if ($string eq '') {
6399 8         11 $modifier =~ tr/bB//d;
6400             $modifier =~ tr/i//d;
6401             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6402             }
6403              
6404             # /b /B modifier
6405             elsif ($modifier =~ tr/bB//d) {
6406 8 0       63  
6407 0         0 # choice again delimiter
6408 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6409 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6410 0         0 my %octet = map {$_ => 1} @char;
6411 0         0 if (not $octet{')'}) {
6412             $delimiter = '(';
6413             $end_delimiter = ')';
6414 0         0 }
6415 0         0 elsif (not $octet{'}'}) {
6416             $delimiter = '{';
6417             $end_delimiter = '}';
6418 0         0 }
6419 0         0 elsif (not $octet{']'}) {
6420             $delimiter = '[';
6421             $end_delimiter = ']';
6422 0         0 }
6423 0         0 elsif (not $octet{'>'}) {
6424             $delimiter = '<';
6425             $end_delimiter = '>';
6426 0         0 }
6427 0 0       0 else {
6428 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6429 0         0 if (not $octet{$char}) {
6430 0         0 $delimiter = $char;
6431             $end_delimiter = $char;
6432             last;
6433             }
6434             }
6435             }
6436 0         0 }
6437 0         0  
6438             my $prematch = '';
6439             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6440 0 100       0 }
6441 68         197  
6442             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6443             my $metachar = qr/[\@\\|[\]{^]/oxms;
6444 68         280  
6445             # split regexp
6446             my @char = $string =~ /\G((?>
6447             [^\\\$\@\[\(] |
6448             \\ (?>[1-9][0-9]*) |
6449             \\g (?>\s*) (?>[1-9][0-9]*) |
6450             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6451             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6452             \\x (?>[0-9A-Fa-f]{1,2}) |
6453             \\ (?>[0-7]{2,3}) |
6454             \\c [\x40-\x5F] |
6455             \\x\{ (?>[0-9A-Fa-f]+) \} |
6456             \\o\{ (?>[0-7]+) \} |
6457             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6458             \\ $q_char |
6459             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6460             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6461             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6462             [\$\@] $qq_variable |
6463             \$ (?>\s* [0-9]+) |
6464             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6465             \$ \$ (?![\w\{]) |
6466             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6467             \[\^ |
6468             \[\: (?>[a-z]+) :\] |
6469             \[\:\^ (?>[a-z]+) :\] |
6470             \(\? |
6471             $q_char
6472             ))/oxmsg;
6473 68 50       18162  
6474 68         461 # choice again delimiter
  0         0  
6475 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6476 0         0 my %octet = map {$_ => 1} @char;
6477 0         0 if (not $octet{')'}) {
6478             $delimiter = '(';
6479             $end_delimiter = ')';
6480 0         0 }
6481 0         0 elsif (not $octet{'}'}) {
6482             $delimiter = '{';
6483             $end_delimiter = '}';
6484 0         0 }
6485 0         0 elsif (not $octet{']'}) {
6486             $delimiter = '[';
6487             $end_delimiter = ']';
6488 0         0 }
6489 0         0 elsif (not $octet{'>'}) {
6490             $delimiter = '<';
6491             $end_delimiter = '>';
6492 0         0 }
6493 0 0       0 else {
6494 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6495 0         0 if (not $octet{$char}) {
6496 0         0 $delimiter = $char;
6497             $end_delimiter = $char;
6498             last;
6499             }
6500             }
6501             }
6502             }
6503 0         0  
  68         139  
6504             # count '('
6505 253         521 my $parens = grep { $_ eq '(' } @char;
6506 68         162  
6507 68         97 my $left_e = 0;
6508             my $right_e = 0;
6509             for (my $i=0; $i <= $#char; $i++) {
6510 68 50 33     215  
    50 33        
    100          
    100          
    50          
    50          
6511 195         1502 # "\L\u" --> "\u\L"
6512             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6513             @char[$i,$i+1] = @char[$i+1,$i];
6514             }
6515              
6516 0         0 # "\U\l" --> "\l\U"
6517             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6518             @char[$i,$i+1] = @char[$i+1,$i];
6519             }
6520              
6521 0         0 # octal escape sequence
6522             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6523             $char[$i] = Elatin2::octchr($1);
6524             }
6525              
6526 1         3 # hexadecimal escape sequence
6527             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6528             $char[$i] = Elatin2::hexchr($1);
6529             }
6530              
6531             # \b{...} --> b\{...}
6532             # \B{...} --> B\{...}
6533             # \N{CHARNAME} --> N\{CHARNAME}
6534             # \p{PROPERTY} --> p\{PROPERTY}
6535 1         4 # \P{PROPERTY} --> P\{PROPERTY}
6536             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6537             $char[$i] = $1 . '\\' . $2;
6538             }
6539              
6540 0         0 # \p, \P, \X --> p, P, X
6541             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6542             $char[$i] = $1;
6543 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          
6544              
6545             if (0) {
6546             }
6547 195         771  
6548 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6549 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6550             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)) {
6551             $char[$i] .= join '', splice @char, $i+1, 3;
6552 0         0 }
6553             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)) {
6554             $char[$i] .= join '', splice @char, $i+1, 2;
6555 0         0 }
6556             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)) {
6557             $char[$i] .= join '', splice @char, $i+1, 1;
6558             }
6559             }
6560              
6561 0         0 # open character class [...]
6562 13 50       30 elsif ($char[$i] eq '[') {
6563 13         63 my $left = $i;
6564             if ($char[$i+1] eq ']') {
6565 0         0 $i++;
6566 13 50       20 }
6567 58         89 while (1) {
6568             if (++$i > $#char) {
6569 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6570 58         112 }
6571             if ($char[$i] eq ']') {
6572             my $right = $i;
6573 13 50       22  
6574 13         81 # [...]
  0         0  
6575             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6576             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);
6577 0         0 }
6578             else {
6579             splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
6580 13         58 }
6581 13         32  
6582             $i = $left;
6583             last;
6584             }
6585             }
6586             }
6587              
6588 13         44 # open character class [^...]
6589 0 0       0 elsif ($char[$i] eq '[^') {
6590 0         0 my $left = $i;
6591             if ($char[$i+1] eq ']') {
6592 0         0 $i++;
6593 0 0       0 }
6594 0         0 while (1) {
6595             if (++$i > $#char) {
6596 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6597 0         0 }
6598             if ($char[$i] eq ']') {
6599             my $right = $i;
6600 0 0       0  
6601 0         0 # [^...]
  0         0  
6602             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6603             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);
6604 0         0 }
6605             else {
6606             splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6607 0         0 }
6608 0         0  
6609             $i = $left;
6610             last;
6611             }
6612             }
6613             }
6614              
6615 0         0 # rewrite character class or escape character
6616             elsif (my $char = character_class($char[$i],$modifier)) {
6617             $char[$i] = $char;
6618             }
6619              
6620 7 50       14 # /i modifier
6621 3         7 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
6622             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
6623             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
6624 3         6 }
6625             else {
6626             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
6627             }
6628             }
6629              
6630 0 0       0 # \u \l \U \L \F \Q \E
6631 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6632             if ($right_e < $left_e) {
6633             $char[$i] = '\\' . $char[$i];
6634             }
6635 0         0 }
6636 0         0 elsif ($char[$i] eq '\u') {
6637             $char[$i] = '@{[Elatin2::ucfirst qq<';
6638             $left_e++;
6639 0         0 }
6640 0         0 elsif ($char[$i] eq '\l') {
6641             $char[$i] = '@{[Elatin2::lcfirst qq<';
6642             $left_e++;
6643 0         0 }
6644 0         0 elsif ($char[$i] eq '\U') {
6645             $char[$i] = '@{[Elatin2::uc qq<';
6646             $left_e++;
6647 0         0 }
6648 0         0 elsif ($char[$i] eq '\L') {
6649             $char[$i] = '@{[Elatin2::lc qq<';
6650             $left_e++;
6651 0         0 }
6652 0         0 elsif ($char[$i] eq '\F') {
6653             $char[$i] = '@{[Elatin2::fc qq<';
6654             $left_e++;
6655 0         0 }
6656 0         0 elsif ($char[$i] eq '\Q') {
6657             $char[$i] = '@{[CORE::quotemeta qq<';
6658             $left_e++;
6659 0 0       0 }
6660 0         0 elsif ($char[$i] eq '\E') {
6661 0         0 if ($right_e < $left_e) {
6662             $char[$i] = '>]}';
6663             $right_e++;
6664 0         0 }
6665             else {
6666             $char[$i] = '';
6667             }
6668 0         0 }
6669 0 0       0 elsif ($char[$i] eq '\Q') {
6670 0         0 while (1) {
6671             if (++$i > $#char) {
6672 0 0       0 last;
6673 0         0 }
6674             if ($char[$i] eq '\E') {
6675             last;
6676             }
6677             }
6678             }
6679             elsif ($char[$i] eq '\E') {
6680             }
6681              
6682             # \0 --> \0
6683             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6684             }
6685              
6686             # \g{N}, \g{-N}
6687              
6688             # P.108 Using Simple Patterns
6689             # in Chapter 7: In the World of Regular Expressions
6690             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6691              
6692             # P.221 Capturing
6693             # in Chapter 5: Pattern Matching
6694             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6695              
6696             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6697             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6698             }
6699              
6700             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6701             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6702             }
6703              
6704             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6705             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6706             }
6707              
6708             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6709             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6710             }
6711              
6712 0 0       0 # $0 --> $0
6713 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6714             if ($ignorecase) {
6715             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6716             }
6717 0 0       0 }
6718 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6719             if ($ignorecase) {
6720             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6721             }
6722             }
6723              
6724             # $$ --> $$
6725             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6726             }
6727              
6728             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6729 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6730 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6731 0         0 $char[$i] = e_capture($1);
6732             if ($ignorecase) {
6733             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6734             }
6735 0         0 }
6736 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6737 0         0 $char[$i] = e_capture($1);
6738             if ($ignorecase) {
6739             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6740             }
6741             }
6742              
6743 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6744 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) {
6745 0         0 $char[$i] = e_capture($1.'->'.$2);
6746             if ($ignorecase) {
6747             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6748             }
6749             }
6750              
6751 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6752 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) {
6753 0         0 $char[$i] = e_capture($1.'->'.$2);
6754             if ($ignorecase) {
6755             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6756             }
6757             }
6758              
6759 0         0 # $$foo
6760 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6761 0         0 $char[$i] = e_capture($1);
6762             if ($ignorecase) {
6763             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6764             }
6765             }
6766              
6767 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
6768 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6769             if ($ignorecase) {
6770             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::PREMATCH())]}';
6771 0         0 }
6772             else {
6773             $char[$i] = '@{[Elatin2::PREMATCH()]}';
6774             }
6775             }
6776              
6777 4 50       14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
6778 4         14 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6779             if ($ignorecase) {
6780             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::MATCH())]}';
6781 0         0 }
6782             else {
6783             $char[$i] = '@{[Elatin2::MATCH()]}';
6784             }
6785             }
6786              
6787 4 50       16 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
6788 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6789             if ($ignorecase) {
6790             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::POSTMATCH())]}';
6791 0         0 }
6792             else {
6793             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
6794             }
6795             }
6796              
6797 3 0       12 # ${ foo }
6798 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) {
6799             if ($ignorecase) {
6800             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6801             }
6802             }
6803              
6804 0         0 # ${ ... }
6805 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6806 0         0 $char[$i] = e_capture($1);
6807             if ($ignorecase) {
6808             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6809             }
6810             }
6811              
6812 0         0 # $scalar or @array
6813 4 50       32 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6814 4         30 $char[$i] = e_string($char[$i]);
6815             if ($ignorecase) {
6816             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
6817             }
6818             }
6819              
6820 0 50       0 # quote character before ? + * {
6821             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6822             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6823 13         76 }
6824             else {
6825             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6826             }
6827             }
6828             }
6829 13         321  
6830 68         178 # make regexp string
6831 68 50       116 my $prematch = '';
6832 68         182 $modifier =~ tr/i//d;
6833             if ($left_e > $right_e) {
6834 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6835             }
6836             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6837             }
6838              
6839             #
6840             # escape regexp (s'here'' or s'here''b)
6841 68     21 0 782 #
6842 21   100     59 sub e_s1_q {
6843             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6844 21         70 $modifier ||= '';
6845 21 50       37  
6846 21         45 $modifier =~ tr/p//d;
6847 0         0 if ($modifier =~ /([adlu])/oxms) {
6848 0 0       0 my $line = 0;
6849 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6850 0         0 if ($filename ne __FILE__) {
6851             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6852             last;
6853 0         0 }
6854             }
6855             die qq{Unsupported modifier "$1" used at line $line.\n};
6856 0         0 }
6857              
6858             $slash = 'div';
6859 21 100       34  
    50          
6860 21         64 # literal null string pattern
6861 8         9 if ($string eq '') {
6862 8         10 $modifier =~ tr/bB//d;
6863             $modifier =~ tr/i//d;
6864             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6865             }
6866              
6867 8         81 # with /b /B modifier
6868             elsif ($modifier =~ tr/bB//d) {
6869             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6870             }
6871              
6872 0         0 # without /b /B modifier
6873             else {
6874             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6875             }
6876             }
6877              
6878             #
6879             # escape regexp (s'here'')
6880 13     13 0 36 #
6881             sub e_s1_qt {
6882 13 50       32 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6883              
6884             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6885 13         27  
6886             # split regexp
6887             my @char = $string =~ /\G((?>
6888             [^\\\[\$\@\/] |
6889             [\x00-\xFF] |
6890             \[\^ |
6891             \[\: (?>[a-z]+) \:\] |
6892             \[\:\^ (?>[a-z]+) \:\] |
6893             [\$\@\/] |
6894             \\ (?:$q_char) |
6895             (?:$q_char)
6896             ))/oxmsg;
6897 13         229  
6898 13 50 33     47 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6899             for (my $i=0; $i <= $#char; $i++) {
6900             if (0) {
6901             }
6902 25         111  
6903 0         0 # open character class [...]
6904 0 0       0 elsif ($char[$i] eq '[') {
6905 0         0 my $left = $i;
6906             if ($char[$i+1] eq ']') {
6907 0         0 $i++;
6908 0 0       0 }
6909 0         0 while (1) {
6910             if (++$i > $#char) {
6911 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6912 0         0 }
6913             if ($char[$i] eq ']') {
6914             my $right = $i;
6915 0         0  
6916             # [...]
6917 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
6918 0         0  
6919             $i = $left;
6920             last;
6921             }
6922             }
6923             }
6924              
6925 0         0 # open character class [^...]
6926 0 0       0 elsif ($char[$i] eq '[^') {
6927 0         0 my $left = $i;
6928             if ($char[$i+1] eq ']') {
6929 0         0 $i++;
6930 0 0       0 }
6931 0         0 while (1) {
6932             if (++$i > $#char) {
6933 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6934 0         0 }
6935             if ($char[$i] eq ']') {
6936             my $right = $i;
6937 0         0  
6938             # [^...]
6939 0         0 splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6940 0         0  
6941             $i = $left;
6942             last;
6943             }
6944             }
6945             }
6946              
6947 0         0 # escape $ @ / and \
6948             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6949             $char[$i] = '\\' . $char[$i];
6950             }
6951              
6952 0         0 # rewrite character class or escape character
6953             elsif (my $char = character_class($char[$i],$modifier)) {
6954             $char[$i] = $char;
6955             }
6956              
6957 6 0       13 # /i modifier
6958 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
6959             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
6960             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
6961 0         0 }
6962             else {
6963             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
6964             }
6965             }
6966              
6967 0 0       0 # quote character before ? + * {
6968             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6969             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6970 0         0 }
6971             else {
6972             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6973             }
6974             }
6975 0         0 }
6976 13         28  
6977 13         22 $modifier =~ tr/i//d;
6978 13         17 $delimiter = '/';
6979 13         26 $end_delimiter = '/';
6980             my $prematch = '';
6981             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6982             }
6983              
6984             #
6985             # escape regexp (s'here''b)
6986 13     0 0 110 #
6987             sub e_s1_qb {
6988             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6989 0         0  
6990             # split regexp
6991             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6992 0         0  
6993 0 0       0 # unescape character
    0          
6994             for (my $i=0; $i <= $#char; $i++) {
6995             if (0) {
6996             }
6997 0         0  
6998             # remain \\
6999             elsif ($char[$i] eq '\\\\') {
7000             }
7001              
7002 0         0 # escape $ @ / and \
7003             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7004             $char[$i] = '\\' . $char[$i];
7005             }
7006 0         0 }
7007 0         0  
7008 0         0 $delimiter = '/';
7009 0         0 $end_delimiter = '/';
7010             my $prematch = '';
7011             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7012             }
7013              
7014             #
7015             # escape regexp (s''here')
7016 0     16 0 0 #
7017             sub e_s2_q {
7018 16         38 my($ope,$delimiter,$end_delimiter,$string) = @_;
7019              
7020 16         22 $slash = 'div';
7021 16         101  
7022 16 100       47 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7023             for (my $i=0; $i <= $#char; $i++) {
7024             if (0) {
7025             }
7026 9         34  
7027             # not escape \\
7028             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7029             }
7030              
7031 0         0 # escape $ @ / and \
7032             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7033             $char[$i] = '\\' . $char[$i];
7034             }
7035 5         15 }
7036              
7037             return join '', $ope, $delimiter, @char, $end_delimiter;
7038             }
7039              
7040             #
7041             # escape regexp (s/here/and here/modifier)
7042 16     97 0 183 #
7043 97   100     866 sub e_sub {
7044             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7045 97         420 $modifier ||= '';
7046 97 50       196  
7047 97         304 $modifier =~ tr/p//d;
7048 0         0 if ($modifier =~ /([adlu])/oxms) {
7049 0 0       0 my $line = 0;
7050 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7051 0         0 if ($filename ne __FILE__) {
7052             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7053             last;
7054 0         0 }
7055             }
7056             die qq{Unsupported modifier "$1" used at line $line.\n};
7057 0 100       0 }
7058 97         268  
7059 36         99 if ($variable eq '') {
7060             $variable = '$_';
7061             $bind_operator = ' =~ ';
7062 36         51 }
7063              
7064             $slash = 'div';
7065              
7066             # P.128 Start of match (or end of previous match): \G
7067             # P.130 Advanced Use of \G with Perl
7068             # in Chapter 3: Overview of Regular Expression Features and Flavors
7069             # P.312 Iterative Matching: Scalar Context, with /g
7070             # in Chapter 7: Perl
7071             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7072              
7073             # P.181 Where You Left Off: The \G Assertion
7074             # in Chapter 5: Pattern Matching
7075             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7076              
7077             # P.220 Where You Left Off: The \G Assertion
7078             # in Chapter 5: Pattern Matching
7079 97         204 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7080 97         165  
7081             my $e_modifier = $modifier =~ tr/e//d;
7082 97         152 my $r_modifier = $modifier =~ tr/r//d;
7083 97 50       145  
7084 97         288 my $my = '';
7085 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7086 0         0 $my = $variable;
7087             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7088             $variable =~ s/ = .+ \z//oxms;
7089 0         0 }
7090 97         263  
7091             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7092             $variable_basename =~ s/ \s+ \z//oxms;
7093 97         189  
7094 97 100       145 # quote replacement string
7095 97         238 my $e_replacement = '';
7096 17         39 if ($e_modifier >= 1) {
7097             $e_replacement = e_qq('', '', '', $replacement);
7098             $e_modifier--;
7099 17 100       32 }
7100 80         206 else {
7101             if ($delimiter2 eq "'") {
7102             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7103 16         36 }
7104             else {
7105             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7106             }
7107 64         161 }
7108              
7109             my $sub = '';
7110 97 100       195  
7111 97 100       265 # with /r
7112             if ($r_modifier) {
7113             if (0) {
7114             }
7115 8         20  
7116 0 50       0 # s///gr without multibyte anchoring
7117             elsif ($modifier =~ /g/oxms) {
7118             $sub = sprintf(
7119             # 1 2 3 4 5
7120             q,
7121              
7122             $variable, # 1
7123             ($delimiter1 eq "'") ? # 2
7124             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7125             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7126             $s_matched, # 3
7127             $e_replacement, # 4
7128             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 5
7129             );
7130             }
7131              
7132             # s///r
7133 4         18 else {
7134              
7135 4 50       7 my $prematch = q{$`};
7136              
7137             $sub = sprintf(
7138             # 1 2 3 4 5 6 7
7139             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin2::re_r=%s; %s"%s$Elatin2::re_r$'" } : %s>,
7140              
7141             $variable, # 1
7142             ($delimiter1 eq "'") ? # 2
7143             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7144             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7145             $s_matched, # 3
7146             $e_replacement, # 4
7147             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 5
7148             $prematch, # 6
7149             $variable, # 7
7150             );
7151             }
7152 4 50       13  
7153 8         27 # $var !~ s///r doesn't make sense
7154             if ($bind_operator =~ / !~ /oxms) {
7155             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7156             }
7157             }
7158              
7159 0 100       0 # without /r
7160             else {
7161             if (0) {
7162             }
7163 89         260  
7164 0 100       0 # s///g without multibyte anchoring
    100          
7165             elsif ($modifier =~ /g/oxms) {
7166             $sub = sprintf(
7167             # 1 2 3 4 5 6 7 8
7168             q,
7169              
7170             $variable, # 1
7171             ($delimiter1 eq "'") ? # 2
7172             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7173             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7174             $s_matched, # 3
7175             $e_replacement, # 4
7176             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 5
7177             $variable, # 6
7178             $variable, # 7
7179             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7180             );
7181             }
7182              
7183             # s///
7184 22         95 else {
7185              
7186 67 100       128 my $prematch = q{$`};
    100          
7187              
7188             $sub = sprintf(
7189              
7190             ($bind_operator =~ / =~ /oxms) ?
7191              
7192             # 1 2 3 4 5 6 7 8
7193             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin2::re_r=%s; %s%s="%s$Elatin2::re_r$'"; 1 } : undef> :
7194              
7195             # 1 2 3 4 5 6 7 8
7196             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin2::re_r=%s; %s%s="%s$Elatin2::re_r$'"; undef }>,
7197              
7198             $variable, # 1
7199             $bind_operator, # 2
7200             ($delimiter1 eq "'") ? # 3
7201             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7202             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7203             $s_matched, # 4
7204             $e_replacement, # 5
7205             '$Elatin2::re_r=CORE::eval $Elatin2::re_r; ' x $e_modifier, # 6
7206             $variable, # 7
7207             $prematch, # 8
7208             );
7209             }
7210             }
7211 67 50       417  
7212 97         285 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7213             if ($my ne '') {
7214             $sub = "($my, $sub)[1]";
7215             }
7216 0         0  
7217 97         163 # clear s/// variable
7218             $sub_variable = '';
7219 97         132 $bind_operator = '';
7220              
7221             return $sub;
7222             }
7223              
7224             #
7225             # escape regexp of split qr//
7226 97     74 0 859 #
7227 74   100     346 sub e_split {
7228             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7229 74         365 $modifier ||= '';
7230 74 50       130  
7231 74         202 $modifier =~ tr/p//d;
7232 0         0 if ($modifier =~ /([adlu])/oxms) {
7233 0 0       0 my $line = 0;
7234 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7235 0         0 if ($filename ne __FILE__) {
7236             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7237             last;
7238 0         0 }
7239             }
7240             die qq{Unsupported modifier "$1" used at line $line.\n};
7241 0         0 }
7242              
7243             $slash = 'div';
7244 74 50       133  
7245 74         178 # /b /B modifier
7246             if ($modifier =~ tr/bB//d) {
7247             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7248 0 50       0 }
7249 74         184  
7250             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7251             my $metachar = qr/[\@\\|[\]{^]/oxms;
7252 74         261  
7253             # split regexp
7254             my @char = $string =~ /\G((?>
7255             [^\\\$\@\[\(] |
7256             \\x (?>[0-9A-Fa-f]{1,2}) |
7257             \\ (?>[0-7]{2,3}) |
7258             \\c [\x40-\x5F] |
7259             \\x\{ (?>[0-9A-Fa-f]+) \} |
7260             \\o\{ (?>[0-7]+) \} |
7261             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7262             \\ $q_char |
7263             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7264             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7265             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7266             [\$\@] $qq_variable |
7267             \$ (?>\s* [0-9]+) |
7268             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7269             \$ \$ (?![\w\{]) |
7270             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7271             \[\^ |
7272             \[\: (?>[a-z]+) :\] |
7273             \[\:\^ (?>[a-z]+) :\] |
7274             \(\? |
7275             $q_char
7276 74         9170 ))/oxmsg;
7277 74         242  
7278 74         138 my $left_e = 0;
7279             my $right_e = 0;
7280             for (my $i=0; $i <= $#char; $i++) {
7281 74 50 33     392  
    50 33        
    100          
    100          
    50          
    50          
7282 249         1291 # "\L\u" --> "\u\L"
7283             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7284             @char[$i,$i+1] = @char[$i+1,$i];
7285             }
7286              
7287 0         0 # "\U\l" --> "\l\U"
7288             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7289             @char[$i,$i+1] = @char[$i+1,$i];
7290             }
7291              
7292 0         0 # octal escape sequence
7293             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7294             $char[$i] = Elatin2::octchr($1);
7295             }
7296              
7297 1         4 # hexadecimal escape sequence
7298             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7299             $char[$i] = Elatin2::hexchr($1);
7300             }
7301              
7302             # \b{...} --> b\{...}
7303             # \B{...} --> B\{...}
7304             # \N{CHARNAME} --> N\{CHARNAME}
7305             # \p{PROPERTY} --> p\{PROPERTY}
7306 1         4 # \P{PROPERTY} --> P\{PROPERTY}
7307             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7308             $char[$i] = $1 . '\\' . $2;
7309             }
7310              
7311 0         0 # \p, \P, \X --> p, P, X
7312             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7313             $char[$i] = $1;
7314 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          
7315              
7316             if (0) {
7317             }
7318 249         839  
7319 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7320 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7321             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)) {
7322             $char[$i] .= join '', splice @char, $i+1, 3;
7323 0         0 }
7324             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)) {
7325             $char[$i] .= join '', splice @char, $i+1, 2;
7326 0         0 }
7327             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)) {
7328             $char[$i] .= join '', splice @char, $i+1, 1;
7329             }
7330             }
7331              
7332 0         0 # open character class [...]
7333 3 50       5 elsif ($char[$i] eq '[') {
7334 3         8 my $left = $i;
7335             if ($char[$i+1] eq ']') {
7336 0         0 $i++;
7337 3 50       6 }
7338 7         12 while (1) {
7339             if (++$i > $#char) {
7340 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7341 7         15 }
7342             if ($char[$i] eq ']') {
7343             my $right = $i;
7344 3 50       5  
7345 3         19 # [...]
  0         0  
7346             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7347             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);
7348 0         0 }
7349             else {
7350             splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
7351 3         18 }
7352 3         4  
7353             $i = $left;
7354             last;
7355             }
7356             }
7357             }
7358              
7359 3         8 # open character class [^...]
7360 0 0       0 elsif ($char[$i] eq '[^') {
7361 0         0 my $left = $i;
7362             if ($char[$i+1] eq ']') {
7363 0         0 $i++;
7364 0 0       0 }
7365 0         0 while (1) {
7366             if (++$i > $#char) {
7367 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7368 0         0 }
7369             if ($char[$i] eq ']') {
7370             my $right = $i;
7371 0 0       0  
7372 0         0 # [^...]
  0         0  
7373             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7374             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);
7375 0         0 }
7376             else {
7377             splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7378 0         0 }
7379 0         0  
7380             $i = $left;
7381             last;
7382             }
7383             }
7384             }
7385              
7386 0         0 # rewrite character class or escape character
7387             elsif (my $char = character_class($char[$i],$modifier)) {
7388             $char[$i] = $char;
7389             }
7390              
7391             # P.794 29.2.161. split
7392             # in Chapter 29: Functions
7393             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7394              
7395             # P.951 split
7396             # in Chapter 27: Functions
7397             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7398              
7399             # said "The //m modifier is assumed when you split on the pattern /^/",
7400             # but perl5.008 is not so. Therefore, this software adds //m.
7401             # (and so on)
7402              
7403 1         4 # split(m/^/) --> split(m/^/m)
7404             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7405             $modifier .= 'm';
7406             }
7407              
7408 7 0       23 # /i modifier
7409 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
7410             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
7411             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
7412 0         0 }
7413             else {
7414             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
7415             }
7416             }
7417              
7418 0 0       0 # \u \l \U \L \F \Q \E
7419 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7420             if ($right_e < $left_e) {
7421             $char[$i] = '\\' . $char[$i];
7422             }
7423 0         0 }
7424 0         0 elsif ($char[$i] eq '\u') {
7425             $char[$i] = '@{[Elatin2::ucfirst qq<';
7426             $left_e++;
7427 0         0 }
7428 0         0 elsif ($char[$i] eq '\l') {
7429             $char[$i] = '@{[Elatin2::lcfirst qq<';
7430             $left_e++;
7431 0         0 }
7432 0         0 elsif ($char[$i] eq '\U') {
7433             $char[$i] = '@{[Elatin2::uc qq<';
7434             $left_e++;
7435 0         0 }
7436 0         0 elsif ($char[$i] eq '\L') {
7437             $char[$i] = '@{[Elatin2::lc qq<';
7438             $left_e++;
7439 0         0 }
7440 0         0 elsif ($char[$i] eq '\F') {
7441             $char[$i] = '@{[Elatin2::fc qq<';
7442             $left_e++;
7443 0         0 }
7444 0         0 elsif ($char[$i] eq '\Q') {
7445             $char[$i] = '@{[CORE::quotemeta qq<';
7446             $left_e++;
7447 0 0       0 }
7448 0         0 elsif ($char[$i] eq '\E') {
7449 0         0 if ($right_e < $left_e) {
7450             $char[$i] = '>]}';
7451             $right_e++;
7452 0         0 }
7453             else {
7454             $char[$i] = '';
7455             }
7456 0         0 }
7457 0 0       0 elsif ($char[$i] eq '\Q') {
7458 0         0 while (1) {
7459             if (++$i > $#char) {
7460 0 0       0 last;
7461 0         0 }
7462             if ($char[$i] eq '\E') {
7463             last;
7464             }
7465             }
7466             }
7467             elsif ($char[$i] eq '\E') {
7468             }
7469              
7470 0 0       0 # $0 --> $0
7471 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7472             if ($ignorecase) {
7473             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7474             }
7475 0 0       0 }
7476 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7477             if ($ignorecase) {
7478             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7479             }
7480             }
7481              
7482             # $$ --> $$
7483             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7484             }
7485              
7486             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7487 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7488 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7489 0         0 $char[$i] = e_capture($1);
7490             if ($ignorecase) {
7491             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7492             }
7493 0         0 }
7494 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7495 0         0 $char[$i] = e_capture($1);
7496             if ($ignorecase) {
7497             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7498             }
7499             }
7500              
7501 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7502 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) {
7503 0         0 $char[$i] = e_capture($1.'->'.$2);
7504             if ($ignorecase) {
7505             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7506             }
7507             }
7508              
7509 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7510 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) {
7511 0         0 $char[$i] = e_capture($1.'->'.$2);
7512             if ($ignorecase) {
7513             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7514             }
7515             }
7516              
7517 0         0 # $$foo
7518 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7519 0         0 $char[$i] = e_capture($1);
7520             if ($ignorecase) {
7521             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7522             }
7523             }
7524              
7525 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin2::PREMATCH()
7526 12         35 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7527             if ($ignorecase) {
7528             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::PREMATCH())]}';
7529 0         0 }
7530             else {
7531             $char[$i] = '@{[Elatin2::PREMATCH()]}';
7532             }
7533             }
7534              
7535 12 50       56 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin2::MATCH()
7536 12         40 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7537             if ($ignorecase) {
7538             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::MATCH())]}';
7539 0         0 }
7540             else {
7541             $char[$i] = '@{[Elatin2::MATCH()]}';
7542             }
7543             }
7544              
7545 12 50       53 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin2::POSTMATCH()
7546 9         23 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7547             if ($ignorecase) {
7548             $char[$i] = '@{[Elatin2::ignorecase(Elatin2::POSTMATCH())]}';
7549 0         0 }
7550             else {
7551             $char[$i] = '@{[Elatin2::POSTMATCH()]}';
7552             }
7553             }
7554              
7555 9 0       38 # ${ foo }
7556 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) {
7557             if ($ignorecase) {
7558             $char[$i] = '@{[Elatin2::ignorecase(' . $1 . ')]}';
7559             }
7560             }
7561              
7562 0         0 # ${ ... }
7563 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7564 0         0 $char[$i] = e_capture($1);
7565             if ($ignorecase) {
7566             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7567             }
7568             }
7569              
7570 0         0 # $scalar or @array
7571 3 50       10 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7572 3         21 $char[$i] = e_string($char[$i]);
7573             if ($ignorecase) {
7574             $char[$i] = '@{[Elatin2::ignorecase(' . $char[$i] . ')]}';
7575             }
7576             }
7577              
7578 0 50       0 # quote character before ? + * {
7579             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7580             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7581 1         8 }
7582             else {
7583             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7584             }
7585             }
7586             }
7587 0         0  
7588 74 50       215 # make regexp string
7589 74         169 $modifier =~ tr/i//d;
7590             if ($left_e > $right_e) {
7591 0         0 return join '', 'Elatin2::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7592             }
7593             return join '', 'Elatin2::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7594             }
7595              
7596             #
7597             # escape regexp of split qr''
7598 74     0 0 707 #
7599 0   0       sub e_split_q {
7600             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7601 0           $modifier ||= '';
7602 0 0          
7603 0           $modifier =~ tr/p//d;
7604 0           if ($modifier =~ /([adlu])/oxms) {
7605 0 0         my $line = 0;
7606 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7607 0           if ($filename ne __FILE__) {
7608             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7609             last;
7610 0           }
7611             }
7612             die qq{Unsupported modifier "$1" used at line $line.\n};
7613 0           }
7614              
7615             $slash = 'div';
7616 0 0          
7617 0           # /b /B modifier
7618             if ($modifier =~ tr/bB//d) {
7619             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7620 0 0         }
7621              
7622             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7623 0            
7624             # split regexp
7625             my @char = $string =~ /\G((?>
7626             [^\\\[] |
7627             [\x00-\xFF] |
7628             \[\^ |
7629             \[\: (?>[a-z]+) \:\] |
7630             \[\:\^ (?>[a-z]+) \:\] |
7631             \\ (?:$q_char) |
7632             (?:$q_char)
7633             ))/oxmsg;
7634 0            
7635 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7636             for (my $i=0; $i <= $#char; $i++) {
7637             if (0) {
7638             }
7639 0            
7640 0           # open character class [...]
7641 0 0         elsif ($char[$i] eq '[') {
7642 0           my $left = $i;
7643             if ($char[$i+1] eq ']') {
7644 0           $i++;
7645 0 0         }
7646 0           while (1) {
7647             if (++$i > $#char) {
7648 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7649 0           }
7650             if ($char[$i] eq ']') {
7651             my $right = $i;
7652 0            
7653             # [...]
7654 0           splice @char, $left, $right-$left+1, Elatin2::charlist_qr(@char[$left+1..$right-1], $modifier);
7655 0            
7656             $i = $left;
7657             last;
7658             }
7659             }
7660             }
7661              
7662 0           # open character class [^...]
7663 0 0         elsif ($char[$i] eq '[^') {
7664 0           my $left = $i;
7665             if ($char[$i+1] eq ']') {
7666 0           $i++;
7667 0 0         }
7668 0           while (1) {
7669             if (++$i > $#char) {
7670 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7671 0           }
7672             if ($char[$i] eq ']') {
7673             my $right = $i;
7674 0            
7675             # [^...]
7676 0           splice @char, $left, $right-$left+1, Elatin2::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7677 0            
7678             $i = $left;
7679             last;
7680             }
7681             }
7682             }
7683              
7684 0           # rewrite character class or escape character
7685             elsif (my $char = character_class($char[$i],$modifier)) {
7686             $char[$i] = $char;
7687             }
7688              
7689 0           # split(m/^/) --> split(m/^/m)
7690             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7691             $modifier .= 'm';
7692             }
7693              
7694 0 0         # /i modifier
7695 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin2::uc($char[$i]) ne Elatin2::fc($char[$i]))) {
7696             if (CORE::length(Elatin2::fc($char[$i])) == 1) {
7697             $char[$i] = '[' . Elatin2::uc($char[$i]) . Elatin2::fc($char[$i]) . ']';
7698 0           }
7699             else {
7700             $char[$i] = '(?:' . Elatin2::uc($char[$i]) . '|' . Elatin2::fc($char[$i]) . ')';
7701             }
7702             }
7703              
7704 0 0         # quote character before ? + * {
7705             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7706             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7707 0           }
7708             else {
7709             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7710             }
7711             }
7712 0           }
7713 0            
7714             $modifier =~ tr/i//d;
7715             return join '', 'Elatin2::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7716             }
7717              
7718             #
7719             # instead of Carp::carp
7720 0     0 0   #
7721 0           sub carp {
7722             my($package,$filename,$line) = caller(1);
7723             print STDERR "@_ at $filename line $line.\n";
7724             }
7725              
7726             #
7727             # instead of Carp::croak
7728 0     0 0   #
7729 0           sub croak {
7730 0           my($package,$filename,$line) = caller(1);
7731             print STDERR "@_ at $filename line $line.\n";
7732             die "\n";
7733             }
7734              
7735             #
7736             # instead of Carp::cluck
7737 0     0 0   #
7738 0           sub cluck {
7739 0           my $i = 0;
7740 0           my @cluck = ();
7741 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7742             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7743 0           $i++;
7744 0           }
7745 0           print STDERR CORE::reverse @cluck;
7746             print STDERR "\n";
7747             print STDERR @_;
7748             }
7749              
7750             #
7751             # instead of Carp::confess
7752 0     0 0   #
7753 0           sub confess {
7754 0           my $i = 0;
7755 0           my @confess = ();
7756 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7757             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7758 0           $i++;
7759 0           }
7760 0           print STDERR CORE::reverse @confess;
7761 0           print STDERR "\n";
7762             print STDERR @_;
7763             die "\n";
7764             }
7765              
7766             1;
7767              
7768             __END__