File Coverage

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


line stmt bran cond sub pod time code
1             package Elatin3;
2 204     204   1220 use strict;
  204         377  
  204         6071  
3             ######################################################################
4             #
5             # Elatin3 - Run-time routines for Latin3.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin3/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   3052 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         623  
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   1056 use vars qw($VERSION);
  204         337  
  204         27338  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   2616 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         430 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         26616 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   14540 CORE::eval q{
  204     204   1347  
  204     62   378  
  204         23211  
  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       95041 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0     0 0 0 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     0 0 0 my($name) = @_;
73              
74 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
75 0         0 return $name;
76             }
77             elsif (Elatin3::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Elatin3::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 0         0 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 0   0 0 0 if (defined $_[1]) {
112 204     204   1624 no strict qw(refs);
  204         367  
  204         12942  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1174 no strict qw(refs);
  204     0   420  
  204         36283  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x00-\xFF]};
148 204     204   1284 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         325  
  204         13909  
149 204     204   1477 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         447  
  204         331185  
150              
151             #
152             # Latin-3 character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # Latin-3 case conversion
158             #
159             my %lc = ();
160             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
161             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
162             my %uc = ();
163             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
164             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
165             my %fc = ();
166             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
167             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Elatin3 \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177              
178             %lc = (%lc,
179             "\xA1" => "\xB1", # LATIN LETTER H WITH STROKE
180             "\xA6" => "\xB6", # LATIN LETTER H WITH CIRCUMFLEX
181             "\xAA" => "\xBA", # LATIN LETTER S WITH CEDILLA
182             "\xAB" => "\xBB", # LATIN LETTER G WITH BREVE
183             "\xAC" => "\xBC", # LATIN LETTER J WITH CIRCUMFLEX
184             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
185             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
186             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
187             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
188             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
189             "\xC5" => "\xE5", # LATIN LETTER C WITH DOT ABOVE
190             "\xC6" => "\xE6", # LATIN LETTER C WITH CIRCUMFLEX
191             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
192             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
193             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
194             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
195             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
196             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
197             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
198             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
199             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
200             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
201             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
202             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
203             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
204             "\xD5" => "\xF5", # LATIN LETTER G WITH DOT ABOVE
205             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
206             "\xD8" => "\xF8", # LATIN LETTER G WITH CIRCUMFLEX
207             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
208             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
209             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
210             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
211             "\xDD" => "\xFD", # LATIN LETTER U WITH BREVE
212             "\xDE" => "\xFE", # LATIN LETTER S WITH CIRCUMFLEX
213             );
214              
215             %uc = (%uc,
216             "\xB1" => "\xA1", # LATIN LETTER H WITH STROKE
217             "\xB6" => "\xA6", # LATIN LETTER H WITH CIRCUMFLEX
218             "\xBA" => "\xAA", # LATIN LETTER S WITH CEDILLA
219             "\xBB" => "\xAB", # LATIN LETTER G WITH BREVE
220             "\xBC" => "\xAC", # LATIN LETTER J WITH CIRCUMFLEX
221             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
222             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
223             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
224             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
225             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
226             "\xE5" => "\xC5", # LATIN LETTER C WITH DOT ABOVE
227             "\xE6" => "\xC6", # LATIN LETTER C WITH CIRCUMFLEX
228             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
229             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
230             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
231             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
232             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
233             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
234             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
235             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
236             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
237             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
238             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
239             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
240             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
241             "\xF5" => "\xD5", # LATIN LETTER G WITH DOT ABOVE
242             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
243             "\xF8" => "\xD8", # LATIN LETTER G WITH CIRCUMFLEX
244             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
245             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
246             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
247             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
248             "\xFD" => "\xDD", # LATIN LETTER U WITH BREVE
249             "\xFE" => "\xDE", # LATIN LETTER S WITH CIRCUMFLEX
250             );
251              
252             %fc = (%fc,
253             "\xA1" => "\xB1", # LATIN CAPITAL LETTER H WITH STROKE --> LATIN SMALL LETTER H WITH STROKE
254             "\xA6" => "\xB6", # LATIN CAPITAL LETTER H WITH CIRCUMFLEX --> LATIN SMALL LETTER H WITH CIRCUMFLEX
255              
256             # CaseFolding-6.1.0.txt
257             # Date: 2011-07-25, 21:21:56 GMT [MD]
258             #
259             # T: special case for uppercase I and dotted uppercase I
260             # - For non-Turkic languages, this mapping is normally not used.
261             # - For Turkic languages (tr, az), this mapping can be used instead of the normal mapping for these characters.
262             # Note that the Turkic mappings do not maintain canonical equivalence without additional processing.
263             # See the discussions of case mapping in the Unicode Standard for more information.
264              
265             #-------------------------------------------------------------------------------
266             "\xA9" => "\x69", # LATIN CAPITAL LETTER I WITH DOT ABOVE
267             # --> LATIN SMALL LETTER I (without COMBINING DOT ABOVE)
268             #-------------------------------------------------------------------------------
269              
270             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH CEDILLA --> LATIN SMALL LETTER S WITH CEDILLA
271             "\xAB" => "\xBB", # LATIN CAPITAL LETTER G WITH BREVE --> LATIN SMALL LETTER G WITH BREVE
272             "\xAC" => "\xBC", # LATIN CAPITAL LETTER J WITH CIRCUMFLEX --> LATIN SMALL LETTER J WITH CIRCUMFLEX
273             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
274             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
275             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
276             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
277             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
278             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH DOT ABOVE --> LATIN SMALL LETTER C WITH DOT ABOVE
279             "\xC6" => "\xE6", # LATIN CAPITAL LETTER C WITH CIRCUMFLEX --> LATIN SMALL LETTER C WITH CIRCUMFLEX
280             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
281             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
282             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
283             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
284             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
285             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
286             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
287             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
288             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
289             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
290             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
291             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
292             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
293             "\xD5" => "\xF5", # LATIN CAPITAL LETTER G WITH DOT ABOVE --> LATIN SMALL LETTER G WITH DOT ABOVE
294             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
295             "\xD8" => "\xF8", # LATIN CAPITAL LETTER G WITH CIRCUMFLEX --> LATIN SMALL LETTER G WITH CIRCUMFLEX
296             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
297             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
298             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
299             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
300             "\xDD" => "\xFD", # LATIN CAPITAL LETTER U WITH BREVE --> LATIN SMALL LETTER U WITH BREVE
301             "\xDE" => "\xFE", # LATIN CAPITAL LETTER S WITH CIRCUMFLEX --> LATIN SMALL LETTER S WITH CIRCUMFLEX
302             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
303             );
304             }
305              
306             else {
307             croak "Don't know my package name '@{[__PACKAGE__]}'";
308             }
309              
310             #
311             # @ARGV wildcard globbing
312             #
313             sub import {
314              
315 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
316 0         0 my @argv = ();
317 0         0 for (@ARGV) {
318              
319             # has space
320 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
321 0 0       0 if (my @glob = Elatin3::glob(qq{"$_"})) {
322 0         0 push @argv, @glob;
323             }
324             else {
325 0         0 push @argv, $_;
326             }
327             }
328              
329             # has wildcard metachar
330             elsif (/\A (?:$q_char)*? [*?] /oxms) {
331 0 0       0 if (my @glob = Elatin3::glob($_)) {
332 0         0 push @argv, @glob;
333             }
334             else {
335 0         0 push @argv, $_;
336             }
337             }
338              
339             # no wildcard globbing
340             else {
341 0         0 push @argv, $_;
342             }
343             }
344 0         0 @ARGV = @argv;
345             }
346              
347 0         0 *Char::ord = \&Latin3::ord;
348 0         0 *Char::ord_ = \&Latin3::ord_;
349 0         0 *Char::reverse = \&Latin3::reverse;
350 0         0 *Char::getc = \&Latin3::getc;
351 0         0 *Char::length = \&Latin3::length;
352 0         0 *Char::substr = \&Latin3::substr;
353 0         0 *Char::index = \&Latin3::index;
354 0         0 *Char::rindex = \&Latin3::rindex;
355 0         0 *Char::eval = \&Latin3::eval;
356 0         0 *Char::escape = \&Latin3::escape;
357 0         0 *Char::escape_token = \&Latin3::escape_token;
358 0         0 *Char::escape_script = \&Latin3::escape_script;
359             }
360              
361             # P.230 Care with Prototypes
362             # in Chapter 6: Subroutines
363             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
364             #
365             # If you aren't careful, you can get yourself into trouble with prototypes.
366             # But if you are careful, you can do a lot of neat things with them. This is
367             # all very powerful, of course, and should only be used in moderation to make
368             # the world a better place.
369              
370             # P.332 Care with Prototypes
371             # in Chapter 7: Subroutines
372             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
373             #
374             # If you aren't careful, you can get yourself into trouble with prototypes.
375             # But if you are careful, you can do a lot of neat things with them. This is
376             # all very powerful, of course, and should only be used in moderation to make
377             # the world a better place.
378              
379             #
380             # Prototypes of subroutines
381             #
382       0     sub unimport {}
383             sub Elatin3::split(;$$$);
384             sub Elatin3::tr($$$$;$);
385             sub Elatin3::chop(@);
386             sub Elatin3::index($$;$);
387             sub Elatin3::rindex($$;$);
388             sub Elatin3::lcfirst(@);
389             sub Elatin3::lcfirst_();
390             sub Elatin3::lc(@);
391             sub Elatin3::lc_();
392             sub Elatin3::ucfirst(@);
393             sub Elatin3::ucfirst_();
394             sub Elatin3::uc(@);
395             sub Elatin3::uc_();
396             sub Elatin3::fc(@);
397             sub Elatin3::fc_();
398             sub Elatin3::ignorecase;
399             sub Elatin3::classic_character_class;
400             sub Elatin3::capture;
401             sub Elatin3::chr(;$);
402             sub Elatin3::chr_();
403             sub Elatin3::glob($);
404             sub Elatin3::glob_();
405              
406             sub Latin3::ord(;$);
407             sub Latin3::ord_();
408             sub Latin3::reverse(@);
409             sub Latin3::getc(;*@);
410             sub Latin3::length(;$);
411             sub Latin3::substr($$;$$);
412             sub Latin3::index($$;$);
413             sub Latin3::rindex($$;$);
414             sub Latin3::escape(;$);
415              
416             #
417             # Regexp work
418             #
419 204         21385 use vars qw(
420             $re_a
421             $re_t
422             $re_n
423             $re_r
424 204     204   1674 );
  204         416  
425              
426             #
427             # Character class
428             #
429 204         1929579 use vars qw(
430             $dot
431             $dot_s
432             $eD
433             $eS
434             $eW
435             $eH
436             $eV
437             $eR
438             $eN
439             $not_alnum
440             $not_alpha
441             $not_ascii
442             $not_blank
443             $not_cntrl
444             $not_digit
445             $not_graph
446             $not_lower
447             $not_lower_i
448             $not_print
449             $not_punct
450             $not_space
451             $not_upper
452             $not_upper_i
453             $not_word
454             $not_xdigit
455             $eb
456             $eB
457 204     204   4311 );
  204         443  
458              
459             ${Elatin3::dot} = qr{(?>[^\x0A])};
460             ${Elatin3::dot_s} = qr{(?>[\x00-\xFF])};
461             ${Elatin3::eD} = qr{(?>[^0-9])};
462              
463             # Vertical tabs are now whitespace
464             # \s in a regex now matches a vertical tab in all circumstances.
465             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
466             # ${Elatin3::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
467             # ${Elatin3::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
468             ${Elatin3::eS} = qr{(?>[^\s])};
469              
470             ${Elatin3::eW} = qr{(?>[^0-9A-Z_a-z])};
471             ${Elatin3::eH} = qr{(?>[^\x09\x20])};
472             ${Elatin3::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
473             ${Elatin3::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
474             ${Elatin3::eN} = qr{(?>[^\x0A])};
475             ${Elatin3::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
476             ${Elatin3::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
477             ${Elatin3::not_ascii} = qr{(?>[^\x00-\x7F])};
478             ${Elatin3::not_blank} = qr{(?>[^\x09\x20])};
479             ${Elatin3::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
480             ${Elatin3::not_digit} = qr{(?>[^\x30-\x39])};
481             ${Elatin3::not_graph} = qr{(?>[^\x21-\x7F])};
482             ${Elatin3::not_lower} = qr{(?>[^\x61-\x7A])};
483             ${Elatin3::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
484             # ${Elatin3::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
485             ${Elatin3::not_print} = qr{(?>[^\x20-\x7F])};
486             ${Elatin3::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
487             ${Elatin3::not_space} = qr{(?>[^\s\x0B])};
488             ${Elatin3::not_upper} = qr{(?>[^\x41-\x5A])};
489             ${Elatin3::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
490             # ${Elatin3::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
491             ${Elatin3::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
492             ${Elatin3::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
493             ${Elatin3::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))};
494             ${Elatin3::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]))};
495              
496             # avoid: Name "Elatin3::foo" used only once: possible typo at here.
497             ${Elatin3::dot} = ${Elatin3::dot};
498             ${Elatin3::dot_s} = ${Elatin3::dot_s};
499             ${Elatin3::eD} = ${Elatin3::eD};
500             ${Elatin3::eS} = ${Elatin3::eS};
501             ${Elatin3::eW} = ${Elatin3::eW};
502             ${Elatin3::eH} = ${Elatin3::eH};
503             ${Elatin3::eV} = ${Elatin3::eV};
504             ${Elatin3::eR} = ${Elatin3::eR};
505             ${Elatin3::eN} = ${Elatin3::eN};
506             ${Elatin3::not_alnum} = ${Elatin3::not_alnum};
507             ${Elatin3::not_alpha} = ${Elatin3::not_alpha};
508             ${Elatin3::not_ascii} = ${Elatin3::not_ascii};
509             ${Elatin3::not_blank} = ${Elatin3::not_blank};
510             ${Elatin3::not_cntrl} = ${Elatin3::not_cntrl};
511             ${Elatin3::not_digit} = ${Elatin3::not_digit};
512             ${Elatin3::not_graph} = ${Elatin3::not_graph};
513             ${Elatin3::not_lower} = ${Elatin3::not_lower};
514             ${Elatin3::not_lower_i} = ${Elatin3::not_lower_i};
515             ${Elatin3::not_print} = ${Elatin3::not_print};
516             ${Elatin3::not_punct} = ${Elatin3::not_punct};
517             ${Elatin3::not_space} = ${Elatin3::not_space};
518             ${Elatin3::not_upper} = ${Elatin3::not_upper};
519             ${Elatin3::not_upper_i} = ${Elatin3::not_upper_i};
520             ${Elatin3::not_word} = ${Elatin3::not_word};
521             ${Elatin3::not_xdigit} = ${Elatin3::not_xdigit};
522             ${Elatin3::eb} = ${Elatin3::eb};
523             ${Elatin3::eB} = ${Elatin3::eB};
524              
525             #
526             # Latin-3 split
527             #
528             sub Elatin3::split(;$$$) {
529              
530             # P.794 29.2.161. split
531             # in Chapter 29: Functions
532             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
533              
534             # P.951 split
535             # in Chapter 27: Functions
536             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
537              
538 0     0 0 0 my $pattern = $_[0];
539 0         0 my $string = $_[1];
540 0         0 my $limit = $_[2];
541              
542             # if $pattern is also omitted or is the literal space, " "
543 0 0       0 if (not defined $pattern) {
544 0         0 $pattern = ' ';
545             }
546              
547             # if $string is omitted, the function splits the $_ string
548 0 0       0 if (not defined $string) {
549 0 0       0 if (defined $_) {
550 0         0 $string = $_;
551             }
552             else {
553 0         0 $string = '';
554             }
555             }
556              
557 0         0 my @split = ();
558              
559             # when string is empty
560 0 0       0 if ($string eq '') {
    0          
561              
562             # resulting list value in list context
563 0 0       0 if (wantarray) {
564 0         0 return @split;
565             }
566              
567             # count of substrings in scalar context
568             else {
569 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
570 0         0 @_ = @split;
571 0         0 return scalar @_;
572             }
573             }
574              
575             # split's first argument is more consistently interpreted
576             #
577             # After some changes earlier in v5.17, split's behavior has been simplified:
578             # if the PATTERN argument evaluates to a string containing one space, it is
579             # treated the way that a literal string containing one space once was.
580             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
581              
582             # if $pattern is also omitted or is the literal space, " ", the function splits
583             # on whitespace, /\s+/, after skipping any leading whitespace
584             # (and so on)
585              
586             elsif ($pattern eq ' ') {
587 0 0       0 if (not defined $limit) {
588 0         0 return CORE::split(' ', $string);
589             }
590             else {
591 0         0 return CORE::split(' ', $string, $limit);
592             }
593             }
594              
595             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
596 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
597              
598             # a pattern capable of matching either the null string or something longer than the
599             # null string will split the value of $string into separate characters wherever it
600             # matches the null string between characters
601             # (and so on)
602              
603 0 0       0 if ('' =~ / \A $pattern \z /xms) {
604 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
605 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
606              
607             # P.1024 Appendix W.10 Multibyte Processing
608             # of ISBN 1-56592-224-7 CJKV Information Processing
609             # (and so on)
610              
611             # the //m modifier is assumed when you split on the pattern /^/
612             # (and so on)
613              
614             # V
615 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
616              
617             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
618             # is included in the resulting list, interspersed with the fields that are ordinarily returned
619             # (and so on)
620              
621 0         0 local $@;
622 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
623 0         0 push @split, CORE::eval('$' . $digit);
624             }
625             }
626             }
627              
628             else {
629 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
630              
631             # V
632 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
633 0         0 local $@;
634 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
635 0         0 push @split, CORE::eval('$' . $digit);
636             }
637             }
638             }
639             }
640              
641             elsif ($limit > 0) {
642 0 0       0 if ('' =~ / \A $pattern \z /xms) {
643 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
644 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
645              
646             # V
647 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
648 0         0 local $@;
649 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
650 0         0 push @split, CORE::eval('$' . $digit);
651             }
652             }
653             }
654             }
655             else {
656 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
657 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
658              
659             # V
660 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
661 0         0 local $@;
662 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
663 0         0 push @split, CORE::eval('$' . $digit);
664             }
665             }
666             }
667             }
668             }
669              
670 0 0       0 if (CORE::length($string) > 0) {
671 0         0 push @split, $string;
672             }
673              
674             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
675 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
676 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
677 0         0 pop @split;
678             }
679             }
680              
681             # resulting list value in list context
682 0 0       0 if (wantarray) {
683 0         0 return @split;
684             }
685              
686             # count of substrings in scalar context
687             else {
688 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
689 0         0 @_ = @split;
690 0         0 return scalar @_;
691             }
692             }
693              
694             #
695             # get last subexpression offsets
696             #
697             sub _last_subexpression_offsets {
698 0     0   0 my $pattern = $_[0];
699              
700             # remove comment
701 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
702              
703 0         0 my $modifier = '';
704 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
705 0         0 $modifier = $1;
706 0         0 $modifier =~ s/-[A-Za-z]*//;
707             }
708              
709             # with /x modifier
710 0         0 my @char = ();
711 0 0       0 if ($modifier =~ /x/oxms) {
712 0         0 @char = $pattern =~ /\G((?>
713             [^\\\#\[\(] |
714             \\ $q_char |
715             \# (?>[^\n]*) $ |
716             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
717             \(\? |
718             $q_char
719             ))/oxmsg;
720             }
721              
722             # without /x modifier
723             else {
724 0         0 @char = $pattern =~ /\G((?>
725             [^\\\[\(] |
726             \\ $q_char |
727             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
728             \(\? |
729             $q_char
730             ))/oxmsg;
731             }
732              
733 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
734             }
735              
736             #
737             # Latin-3 transliteration (tr///)
738             #
739             sub Elatin3::tr($$$$;$) {
740              
741 0     0 0 0 my $bind_operator = $_[1];
742 0         0 my $searchlist = $_[2];
743 0         0 my $replacementlist = $_[3];
744 0   0     0 my $modifier = $_[4] || '';
745              
746 0 0       0 if ($modifier =~ /r/oxms) {
747 0 0       0 if ($bind_operator =~ / !~ /oxms) {
748 0         0 croak "Using !~ with tr///r doesn't make sense";
749             }
750             }
751              
752 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
753 0         0 my @searchlist = _charlist_tr($searchlist);
754 0         0 my @replacementlist = _charlist_tr($replacementlist);
755              
756 0         0 my %tr = ();
757 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
758 0 0       0 if (not exists $tr{$searchlist[$i]}) {
759 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
760 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
761             }
762             elsif ($modifier =~ /d/oxms) {
763 0         0 $tr{$searchlist[$i]} = '';
764             }
765             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
766 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
767             }
768             else {
769 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
770             }
771             }
772             }
773              
774 0         0 my $tr = 0;
775 0         0 my $replaced = '';
776 0 0       0 if ($modifier =~ /c/oxms) {
777 0         0 while (defined(my $char = shift @char)) {
778 0 0       0 if (not exists $tr{$char}) {
779 0 0       0 if (defined $replacementlist[0]) {
780 0         0 $replaced .= $replacementlist[0];
781             }
782 0         0 $tr++;
783 0 0       0 if ($modifier =~ /s/oxms) {
784 0   0     0 while (@char and (not exists $tr{$char[0]})) {
785 0         0 shift @char;
786 0         0 $tr++;
787             }
788             }
789             }
790             else {
791 0         0 $replaced .= $char;
792             }
793             }
794             }
795             else {
796 0         0 while (defined(my $char = shift @char)) {
797 0 0       0 if (exists $tr{$char}) {
798 0         0 $replaced .= $tr{$char};
799 0         0 $tr++;
800 0 0       0 if ($modifier =~ /s/oxms) {
801 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
802 0         0 shift @char;
803 0         0 $tr++;
804             }
805             }
806             }
807             else {
808 0         0 $replaced .= $char;
809             }
810             }
811             }
812              
813 0 0       0 if ($modifier =~ /r/oxms) {
814 0         0 return $replaced;
815             }
816             else {
817 0         0 $_[0] = $replaced;
818 0 0       0 if ($bind_operator =~ / !~ /oxms) {
819 0         0 return not $tr;
820             }
821             else {
822 0         0 return $tr;
823             }
824             }
825             }
826              
827             #
828             # Latin-3 chop
829             #
830             sub Elatin3::chop(@) {
831              
832 0     0 0 0 my $chop;
833 0 0       0 if (@_ == 0) {
834 0         0 my @char = /\G (?>$q_char) /oxmsg;
835 0         0 $chop = pop @char;
836 0         0 $_ = join '', @char;
837             }
838             else {
839 0         0 for (@_) {
840 0         0 my @char = /\G (?>$q_char) /oxmsg;
841 0         0 $chop = pop @char;
842 0         0 $_ = join '', @char;
843             }
844             }
845 0         0 return $chop;
846             }
847              
848             #
849             # Latin-3 index by octet
850             #
851             sub Elatin3::index($$;$) {
852              
853 0     0 1 0 my($str,$substr,$position) = @_;
854 0   0     0 $position ||= 0;
855 0         0 my $pos = 0;
856              
857 0         0 while ($pos < CORE::length($str)) {
858 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
859 0 0       0 if ($pos >= $position) {
860 0         0 return $pos;
861             }
862             }
863 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
864 0         0 $pos += CORE::length($1);
865             }
866             else {
867 0         0 $pos += 1;
868             }
869             }
870 0         0 return -1;
871             }
872              
873             #
874             # Latin-3 reverse index
875             #
876             sub Elatin3::rindex($$;$) {
877              
878 0     0 0 0 my($str,$substr,$position) = @_;
879 0   0     0 $position ||= CORE::length($str) - 1;
880 0         0 my $pos = 0;
881 0         0 my $rindex = -1;
882              
883 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
884 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
885 0         0 $rindex = $pos;
886             }
887 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
888 0         0 $pos += CORE::length($1);
889             }
890             else {
891 0         0 $pos += 1;
892             }
893             }
894 0         0 return $rindex;
895             }
896              
897             #
898             # Latin-3 lower case first with parameter
899             #
900             sub Elatin3::lcfirst(@) {
901 0 0   0 0 0 if (@_) {
902 0         0 my $s = shift @_;
903 0 0 0     0 if (@_ and wantarray) {
904 0         0 return Elatin3::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
905             }
906             else {
907 0         0 return Elatin3::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
908             }
909             }
910             else {
911 0         0 return Elatin3::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
912             }
913             }
914              
915             #
916             # Latin-3 lower case first without parameter
917             #
918             sub Elatin3::lcfirst_() {
919 0     0 0 0 return Elatin3::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
920             }
921              
922             #
923             # Latin-3 lower case with parameter
924             #
925             sub Elatin3::lc(@) {
926 0 0   0 0 0 if (@_) {
927 0         0 my $s = shift @_;
928 0 0 0     0 if (@_ and wantarray) {
929 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
930             }
931             else {
932 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
933             }
934             }
935             else {
936 0         0 return Elatin3::lc_();
937             }
938             }
939              
940             #
941             # Latin-3 lower case without parameter
942             #
943             sub Elatin3::lc_() {
944 0     0 0 0 my $s = $_;
945 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
946             }
947              
948             #
949             # Latin-3 upper case first with parameter
950             #
951             sub Elatin3::ucfirst(@) {
952 0 0   0 0 0 if (@_) {
953 0         0 my $s = shift @_;
954 0 0 0     0 if (@_ and wantarray) {
955 0         0 return Elatin3::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
956             }
957             else {
958 0         0 return Elatin3::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
959             }
960             }
961             else {
962 0         0 return Elatin3::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
963             }
964             }
965              
966             #
967             # Latin-3 upper case first without parameter
968             #
969             sub Elatin3::ucfirst_() {
970 0     0 0 0 return Elatin3::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
971             }
972              
973             #
974             # Latin-3 upper case with parameter
975             #
976             sub Elatin3::uc(@) {
977 0 50   174 0 0 if (@_) {
978 174         265 my $s = shift @_;
979 174 50 33     216 if (@_ and wantarray) {
980 174 0       419 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
981             }
982             else {
983 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         539  
984             }
985             }
986             else {
987 174         652 return Elatin3::uc_();
988             }
989             }
990              
991             #
992             # Latin-3 upper case without parameter
993             #
994             sub Elatin3::uc_() {
995 0     0 0 0 my $s = $_;
996 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
997             }
998              
999             #
1000             # Latin-3 fold case with parameter
1001             #
1002             sub Elatin3::fc(@) {
1003 0 50   197 0 0 if (@_) {
1004 197         281 my $s = shift @_;
1005 197 50 33     231 if (@_ and wantarray) {
1006 197 0       338 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1007             }
1008             else {
1009 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         489  
1010             }
1011             }
1012             else {
1013 197         1067 return Elatin3::fc_();
1014             }
1015             }
1016              
1017             #
1018             # Latin-3 fold case without parameter
1019             #
1020             sub Elatin3::fc_() {
1021 0     0 0 0 my $s = $_;
1022 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1023             }
1024              
1025             #
1026             # Latin-3 regexp capture
1027             #
1028             {
1029             sub Elatin3::capture {
1030 0     0 1 0 return $_[0];
1031             }
1032             }
1033              
1034             #
1035             # Latin-3 regexp ignore case modifier
1036             #
1037             sub Elatin3::ignorecase {
1038              
1039 0     0 0 0 my @string = @_;
1040 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1041              
1042             # ignore case of $scalar or @array
1043 0         0 for my $string (@string) {
1044              
1045             # split regexp
1046 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1047              
1048             # unescape character
1049 0         0 for (my $i=0; $i <= $#char; $i++) {
1050 0 0       0 next if not defined $char[$i];
1051              
1052             # open character class [...]
1053 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1054 0         0 my $left = $i;
1055              
1056             # [] make die "unmatched [] in regexp ...\n"
1057              
1058 0 0       0 if ($char[$i+1] eq ']') {
1059 0         0 $i++;
1060             }
1061              
1062 0         0 while (1) {
1063 0 0       0 if (++$i > $#char) {
1064 0         0 croak "Unmatched [] in regexp";
1065             }
1066 0 0       0 if ($char[$i] eq ']') {
1067 0         0 my $right = $i;
1068 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1069              
1070             # escape character
1071 0         0 for my $char (@charlist) {
1072 0 0       0 if (0) {
1073             }
1074              
1075 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1076 0         0 $char = '\\' . $char;
1077             }
1078             }
1079              
1080             # [...]
1081 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1082              
1083 0         0 $i = $left;
1084 0         0 last;
1085             }
1086             }
1087             }
1088              
1089             # open character class [^...]
1090             elsif ($char[$i] eq '[^') {
1091 0         0 my $left = $i;
1092              
1093             # [^] make die "unmatched [] in regexp ...\n"
1094              
1095 0 0       0 if ($char[$i+1] eq ']') {
1096 0         0 $i++;
1097             }
1098              
1099 0         0 while (1) {
1100 0 0       0 if (++$i > $#char) {
1101 0         0 croak "Unmatched [] in regexp";
1102             }
1103 0 0       0 if ($char[$i] eq ']') {
1104 0         0 my $right = $i;
1105 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1106              
1107             # escape character
1108 0         0 for my $char (@charlist) {
1109 0 0       0 if (0) {
1110             }
1111              
1112 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1113 0         0 $char = '\\' . $char;
1114             }
1115             }
1116              
1117             # [^...]
1118 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1119              
1120 0         0 $i = $left;
1121 0         0 last;
1122             }
1123             }
1124             }
1125              
1126             # rewrite classic character class or escape character
1127             elsif (my $char = classic_character_class($char[$i])) {
1128 0         0 $char[$i] = $char;
1129             }
1130              
1131             # with /i modifier
1132             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1133 0         0 my $uc = Elatin3::uc($char[$i]);
1134 0         0 my $fc = Elatin3::fc($char[$i]);
1135 0 0       0 if ($uc ne $fc) {
1136 0 0       0 if (CORE::length($fc) == 1) {
1137 0         0 $char[$i] = '[' . $uc . $fc . ']';
1138             }
1139             else {
1140 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1141             }
1142             }
1143             }
1144             }
1145              
1146             # characterize
1147 0         0 for (my $i=0; $i <= $#char; $i++) {
1148 0 0       0 next if not defined $char[$i];
1149              
1150 0 0       0 if (0) {
1151             }
1152              
1153             # quote character before ? + * {
1154 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1155 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1156 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1157             }
1158             }
1159             }
1160              
1161 0         0 $string = join '', @char;
1162             }
1163              
1164             # make regexp string
1165 0         0 return @string;
1166             }
1167              
1168             #
1169             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1170             #
1171             sub Elatin3::classic_character_class {
1172 0     1867 0 0 my($char) = @_;
1173              
1174             return {
1175             '\D' => '${Elatin3::eD}',
1176             '\S' => '${Elatin3::eS}',
1177             '\W' => '${Elatin3::eW}',
1178             '\d' => '[0-9]',
1179              
1180             # Before Perl 5.6, \s only matched the five whitespace characters
1181             # tab, newline, form-feed, carriage return, and the space character
1182             # itself, which, taken together, is the character class [\t\n\f\r ].
1183              
1184             # Vertical tabs are now whitespace
1185             # \s in a regex now matches a vertical tab in all circumstances.
1186             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1187             # \t \n \v \f \r space
1188             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1189             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1190             '\s' => '\s',
1191              
1192             '\w' => '[0-9A-Z_a-z]',
1193             '\C' => '[\x00-\xFF]',
1194             '\X' => 'X',
1195              
1196             # \h \v \H \V
1197              
1198             # P.114 Character Class Shortcuts
1199             # in Chapter 7: In the World of Regular Expressions
1200             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1201              
1202             # P.357 13.2.3 Whitespace
1203             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1204             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1205             #
1206             # 0x00009 CHARACTER TABULATION h s
1207             # 0x0000a LINE FEED (LF) vs
1208             # 0x0000b LINE TABULATION v
1209             # 0x0000c FORM FEED (FF) vs
1210             # 0x0000d CARRIAGE RETURN (CR) vs
1211             # 0x00020 SPACE h s
1212              
1213             # P.196 Table 5-9. Alphanumeric regex metasymbols
1214             # in Chapter 5. Pattern Matching
1215             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1216              
1217             # (and so on)
1218              
1219             '\H' => '${Elatin3::eH}',
1220             '\V' => '${Elatin3::eV}',
1221             '\h' => '[\x09\x20]',
1222             '\v' => '[\x0A\x0B\x0C\x0D]',
1223             '\R' => '${Elatin3::eR}',
1224              
1225             # \N
1226             #
1227             # http://perldoc.perl.org/perlre.html
1228             # Character Classes and other Special Escapes
1229             # Any character but \n (experimental). Not affected by /s modifier
1230              
1231             '\N' => '${Elatin3::eN}',
1232              
1233             # \b \B
1234              
1235             # P.180 Boundaries: The \b and \B Assertions
1236             # in Chapter 5: Pattern Matching
1237             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1238              
1239             # P.219 Boundaries: The \b and \B Assertions
1240             # in Chapter 5: Pattern Matching
1241             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1242              
1243             # \b really means (?:(?<=\w)(?!\w)|(?
1244             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1245             '\b' => '${Elatin3::eb}',
1246              
1247             # \B really means (?:(?<=\w)(?=\w)|(?
1248             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1249             '\B' => '${Elatin3::eB}',
1250              
1251 1867   100     2468 }->{$char} || '';
1252             }
1253              
1254             #
1255             # prepare Latin-3 characters per length
1256             #
1257              
1258             # 1 octet characters
1259             my @chars1 = ();
1260             sub chars1 {
1261 1867 0   0 0 65246 if (@chars1) {
1262 0         0 return @chars1;
1263             }
1264 0 0       0 if (exists $range_tr{1}) {
1265 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1266 0         0 while (my @range = splice(@ranges,0,1)) {
1267 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1268 0         0 push @chars1, pack 'C', $oct0;
1269             }
1270             }
1271             }
1272 0         0 return @chars1;
1273             }
1274              
1275             # 2 octets characters
1276             my @chars2 = ();
1277             sub chars2 {
1278 0 0   0 0 0 if (@chars2) {
1279 0         0 return @chars2;
1280             }
1281 0 0       0 if (exists $range_tr{2}) {
1282 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1283 0         0 while (my @range = splice(@ranges,0,2)) {
1284 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1285 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1286 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1287             }
1288             }
1289             }
1290             }
1291 0         0 return @chars2;
1292             }
1293              
1294             # 3 octets characters
1295             my @chars3 = ();
1296             sub chars3 {
1297 0 0   0 0 0 if (@chars3) {
1298 0         0 return @chars3;
1299             }
1300 0 0       0 if (exists $range_tr{3}) {
1301 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1302 0         0 while (my @range = splice(@ranges,0,3)) {
1303 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1304 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1305 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1306 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1307             }
1308             }
1309             }
1310             }
1311             }
1312 0         0 return @chars3;
1313             }
1314              
1315             # 4 octets characters
1316             my @chars4 = ();
1317             sub chars4 {
1318 0 0   0 0 0 if (@chars4) {
1319 0         0 return @chars4;
1320             }
1321 0 0       0 if (exists $range_tr{4}) {
1322 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1323 0         0 while (my @range = splice(@ranges,0,4)) {
1324 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1325 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1326 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1327 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1328 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1329             }
1330             }
1331             }
1332             }
1333             }
1334             }
1335 0         0 return @chars4;
1336             }
1337              
1338             #
1339             # Latin-3 open character list for tr
1340             #
1341             sub _charlist_tr {
1342              
1343 0     0   0 local $_ = shift @_;
1344              
1345             # unescape character
1346 0         0 my @char = ();
1347 0         0 while (not /\G \z/oxmsgc) {
1348 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1349 0         0 push @char, '\-';
1350             }
1351             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1352 0         0 push @char, CORE::chr(oct $1);
1353             }
1354             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1355 0         0 push @char, CORE::chr(hex $1);
1356             }
1357             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1358 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1359             }
1360             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1361             push @char, {
1362             '\0' => "\0",
1363             '\n' => "\n",
1364             '\r' => "\r",
1365             '\t' => "\t",
1366             '\f' => "\f",
1367             '\b' => "\x08", # \b means backspace in character class
1368             '\a' => "\a",
1369             '\e' => "\e",
1370 0         0 }->{$1};
1371             }
1372             elsif (/\G \\ ($q_char) /oxmsgc) {
1373 0         0 push @char, $1;
1374             }
1375             elsif (/\G ($q_char) /oxmsgc) {
1376 0         0 push @char, $1;
1377             }
1378             }
1379              
1380             # join separated multiple-octet
1381 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1382              
1383             # unescape '-'
1384 0         0 my @i = ();
1385 0         0 for my $i (0 .. $#char) {
1386 0 0       0 if ($char[$i] eq '\-') {
    0          
1387 0         0 $char[$i] = '-';
1388             }
1389             elsif ($char[$i] eq '-') {
1390 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1391 0         0 push @i, $i;
1392             }
1393             }
1394             }
1395              
1396             # open character list (reverse for splice)
1397 0         0 for my $i (CORE::reverse @i) {
1398 0         0 my @range = ();
1399              
1400             # range error
1401 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1402 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1403             }
1404              
1405             # range of multiple-octet code
1406 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1407 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1408 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1409             }
1410             elsif (CORE::length($char[$i+1]) == 2) {
1411 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1412 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1413             }
1414             elsif (CORE::length($char[$i+1]) == 3) {
1415 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1416 0         0 push @range, chars2();
1417 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1418             }
1419             elsif (CORE::length($char[$i+1]) == 4) {
1420 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1421 0         0 push @range, chars2();
1422 0         0 push @range, chars3();
1423 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1424             }
1425             else {
1426 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1427             }
1428             }
1429             elsif (CORE::length($char[$i-1]) == 2) {
1430 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1431 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1432             }
1433             elsif (CORE::length($char[$i+1]) == 3) {
1434 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1435 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1436             }
1437             elsif (CORE::length($char[$i+1]) == 4) {
1438 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1439 0         0 push @range, chars3();
1440 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1441             }
1442             else {
1443 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1444             }
1445             }
1446             elsif (CORE::length($char[$i-1]) == 3) {
1447 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1448 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1449             }
1450             elsif (CORE::length($char[$i+1]) == 4) {
1451 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1452 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1453             }
1454             else {
1455 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1456             }
1457             }
1458             elsif (CORE::length($char[$i-1]) == 4) {
1459 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1460 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ 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             else {
1467 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1468             }
1469              
1470 0         0 splice @char, $i-1, 3, @range;
1471             }
1472              
1473 0         0 return @char;
1474             }
1475              
1476             #
1477             # Latin-3 open character class
1478             #
1479             sub _cc {
1480 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1481 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1482             }
1483             elsif (scalar(@_) == 1) {
1484 0         0 return sprintf('\x%02X',$_[0]);
1485             }
1486             elsif (scalar(@_) == 2) {
1487 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1488 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1489             }
1490             elsif ($_[0] == $_[1]) {
1491 0         0 return sprintf('\x%02X',$_[0]);
1492             }
1493             elsif (($_[0]+1) == $_[1]) {
1494 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1495             }
1496             else {
1497 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1498             }
1499             }
1500             else {
1501 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1502             }
1503             }
1504              
1505             #
1506             # Latin-3 octet range
1507             #
1508             sub _octets {
1509 0     182   0 my $length = shift @_;
1510              
1511 182 50       297 if ($length == 1) {
1512 182         338 my($a1) = unpack 'C', $_[0];
1513 182         459 my($z1) = unpack 'C', $_[1];
1514              
1515 182 50       300 if ($a1 > $z1) {
1516 182         342 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1517             }
1518              
1519 0 50       0 if ($a1 == $z1) {
    50          
1520 182         383 return sprintf('\x%02X',$a1);
1521             }
1522             elsif (($a1+1) == $z1) {
1523 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1524             }
1525             else {
1526 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1527             }
1528             }
1529             else {
1530 182         1073 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1531             }
1532             }
1533              
1534             #
1535             # Latin-3 range regexp
1536             #
1537             sub _range_regexp {
1538 0     182   0 my($length,$first,$last) = @_;
1539              
1540 182         348 my @range_regexp = ();
1541 182 50       234 if (not exists $range_tr{$length}) {
1542 182         391 return @range_regexp;
1543             }
1544              
1545 0         0 my @ranges = @{ $range_tr{$length} };
  182         257  
1546 182         383 while (my @range = splice(@ranges,0,$length)) {
1547 182         493 my $min = '';
1548 182         253 my $max = '';
1549 182         220 for (my $i=0; $i < $length; $i++) {
1550 182         447 $min .= pack 'C', $range[$i][0];
1551 182         582 $max .= pack 'C', $range[$i][-1];
1552             }
1553              
1554             # min___max
1555             # FIRST_____________LAST
1556             # (nothing)
1557              
1558 182 50 33     401 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1559             }
1560              
1561             # **********
1562             # min_________max
1563             # FIRST_____________LAST
1564             # **********
1565              
1566             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1567 182         1868 push @range_regexp, _octets($length,$first,$max,$min,$max);
1568             }
1569              
1570             # **********************
1571             # min________________max
1572             # FIRST_____________LAST
1573             # **********************
1574              
1575             elsif (($min eq $first) and ($max eq $last)) {
1576 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1577             }
1578              
1579             # *********
1580             # min___max
1581             # FIRST_____________LAST
1582             # *********
1583              
1584             elsif (($first le $min) and ($max le $last)) {
1585 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1586             }
1587              
1588             # **********************
1589             # min__________________________max
1590             # FIRST_____________LAST
1591             # **********************
1592              
1593             elsif (($min le $first) and ($last le $max)) {
1594 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1595             }
1596              
1597             # *********
1598             # min________max
1599             # FIRST_____________LAST
1600             # *********
1601              
1602             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1603 182         429 push @range_regexp, _octets($length,$min,$last,$min,$max);
1604             }
1605              
1606             # min___max
1607             # FIRST_____________LAST
1608             # (nothing)
1609              
1610             elsif ($last lt $min) {
1611             }
1612              
1613             else {
1614 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1615             }
1616             }
1617              
1618 0         0 return @range_regexp;
1619             }
1620              
1621             #
1622             # Latin-3 open character list for qr and not qr
1623             #
1624             sub _charlist {
1625              
1626 182     358   368 my $modifier = pop @_;
1627 358         558 my @char = @_;
1628              
1629 358 100       733 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1630              
1631             # unescape character
1632 358         1128 for (my $i=0; $i <= $#char; $i++) {
1633              
1634             # escape - to ...
1635 358 100 100     1291 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1636 1125 100 100     7683 if ((0 < $i) and ($i < $#char)) {
1637 206         774 $char[$i] = '...';
1638             }
1639             }
1640              
1641             # octal escape sequence
1642             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1643 182         368 $char[$i] = octchr($1);
1644             }
1645              
1646             # hexadecimal escape sequence
1647             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1648 0         0 $char[$i] = hexchr($1);
1649             }
1650              
1651             # \b{...} --> b\{...}
1652             # \B{...} --> B\{...}
1653             # \N{CHARNAME} --> N\{CHARNAME}
1654             # \p{PROPERTY} --> p\{PROPERTY}
1655             # \P{PROPERTY} --> P\{PROPERTY}
1656             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1657 0         0 $char[$i] = $1 . '\\' . $2;
1658             }
1659              
1660             # \p, \P, \X --> p, P, X
1661             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1662 0         0 $char[$i] = $1;
1663             }
1664              
1665             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1666 0         0 $char[$i] = CORE::chr oct $1;
1667             }
1668             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1669 0         0 $char[$i] = CORE::chr hex $1;
1670             }
1671             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1672 22         99 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1673             }
1674             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1675             $char[$i] = {
1676             '\0' => "\0",
1677             '\n' => "\n",
1678             '\r' => "\r",
1679             '\t' => "\t",
1680             '\f' => "\f",
1681             '\b' => "\x08", # \b means backspace in character class
1682             '\a' => "\a",
1683             '\e' => "\e",
1684             '\d' => '[0-9]',
1685              
1686             # Vertical tabs are now whitespace
1687             # \s in a regex now matches a vertical tab in all circumstances.
1688             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1689             # \t \n \v \f \r space
1690             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1691             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1692             '\s' => '\s',
1693              
1694             '\w' => '[0-9A-Z_a-z]',
1695             '\D' => '${Elatin3::eD}',
1696             '\S' => '${Elatin3::eS}',
1697             '\W' => '${Elatin3::eW}',
1698              
1699             '\H' => '${Elatin3::eH}',
1700             '\V' => '${Elatin3::eV}',
1701             '\h' => '[\x09\x20]',
1702             '\v' => '[\x0A\x0B\x0C\x0D]',
1703             '\R' => '${Elatin3::eR}',
1704              
1705 0         0 }->{$1};
1706             }
1707              
1708             # POSIX-style character classes
1709             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1710             $char[$i] = {
1711              
1712             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1713             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1714             '[:^lower:]' => '${Elatin3::not_lower_i}',
1715             '[:^upper:]' => '${Elatin3::not_upper_i}',
1716              
1717 25         364 }->{$1};
1718             }
1719             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1720             $char[$i] = {
1721              
1722             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1723             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1724             '[:ascii:]' => '[\x00-\x7F]',
1725             '[:blank:]' => '[\x09\x20]',
1726             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1727             '[:digit:]' => '[\x30-\x39]',
1728             '[:graph:]' => '[\x21-\x7F]',
1729             '[:lower:]' => '[\x61-\x7A]',
1730             '[:print:]' => '[\x20-\x7F]',
1731             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1732              
1733             # P.174 POSIX-Style Character Classes
1734             # in Chapter 5: Pattern Matching
1735             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1736              
1737             # P.311 11.2.4 Character Classes and other Special Escapes
1738             # in Chapter 11: perlre: Perl regular expressions
1739             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1740              
1741             # P.210 POSIX-Style Character Classes
1742             # in Chapter 5: Pattern Matching
1743             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1744              
1745             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1746              
1747             '[:upper:]' => '[\x41-\x5A]',
1748             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1749             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1750             '[:^alnum:]' => '${Elatin3::not_alnum}',
1751             '[:^alpha:]' => '${Elatin3::not_alpha}',
1752             '[:^ascii:]' => '${Elatin3::not_ascii}',
1753             '[:^blank:]' => '${Elatin3::not_blank}',
1754             '[:^cntrl:]' => '${Elatin3::not_cntrl}',
1755             '[:^digit:]' => '${Elatin3::not_digit}',
1756             '[:^graph:]' => '${Elatin3::not_graph}',
1757             '[:^lower:]' => '${Elatin3::not_lower}',
1758             '[:^print:]' => '${Elatin3::not_print}',
1759             '[:^punct:]' => '${Elatin3::not_punct}',
1760             '[:^space:]' => '${Elatin3::not_space}',
1761             '[:^upper:]' => '${Elatin3::not_upper}',
1762             '[:^word:]' => '${Elatin3::not_word}',
1763             '[:^xdigit:]' => '${Elatin3::not_xdigit}',
1764              
1765 8         57 }->{$1};
1766             }
1767             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1768 70         2661 $char[$i] = $1;
1769             }
1770             }
1771              
1772             # open character list
1773 7         31 my @singleoctet = ();
1774 358         602 my @multipleoctet = ();
1775 358         520 for (my $i=0; $i <= $#char; ) {
1776              
1777             # escaped -
1778 358 100 100     1042 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1779 943         3956 $i += 1;
1780 182         238 next;
1781             }
1782              
1783             # make range regexp
1784             elsif ($char[$i] eq '...') {
1785              
1786             # range error
1787 182 50       308 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1788 182         712 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1789             }
1790             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1791 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1792 182         447 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1793             }
1794             }
1795              
1796             # make range regexp per length
1797 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1798 182         465 my @regexp = ();
1799              
1800             # is first and last
1801 182 50 33     231 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1802 182         812 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1803             }
1804              
1805             # is first
1806             elsif ($length == CORE::length($char[$i-1])) {
1807 182         456 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1808             }
1809              
1810             # is inside in first and last
1811             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1812 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1813             }
1814              
1815             # is last
1816             elsif ($length == CORE::length($char[$i+1])) {
1817 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1818             }
1819              
1820             else {
1821 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1822             }
1823              
1824 0 50       0 if ($length == 1) {
1825 182         360 push @singleoctet, @regexp;
1826             }
1827             else {
1828 182         436 push @multipleoctet, @regexp;
1829             }
1830             }
1831              
1832 0         0 $i += 2;
1833             }
1834              
1835             # with /i modifier
1836             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1837 182 100       347 if ($modifier =~ /i/oxms) {
1838 493         1404 my $uc = Elatin3::uc($char[$i]);
1839 24         54 my $fc = Elatin3::fc($char[$i]);
1840 24 100       59 if ($uc ne $fc) {
1841 24 50       52 if (CORE::length($fc) == 1) {
1842 12         73 push @singleoctet, $uc, $fc;
1843             }
1844             else {
1845 12         26 push @singleoctet, $uc;
1846 0         0 push @multipleoctet, $fc;
1847             }
1848             }
1849             else {
1850 0         0 push @singleoctet, $char[$i];
1851             }
1852             }
1853             else {
1854 12         43 push @singleoctet, $char[$i];
1855             }
1856 469         1102 $i += 1;
1857             }
1858              
1859             # single character of single octet code
1860             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1861 493         878 push @singleoctet, "\t", "\x20";
1862 0         0 $i += 1;
1863             }
1864             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1865 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1866 0         0 $i += 1;
1867             }
1868             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1869 0         0 push @singleoctet, $char[$i];
1870 2         5 $i += 1;
1871             }
1872              
1873             # single character of multiple-octet code
1874             else {
1875 2         6 push @multipleoctet, $char[$i];
1876 84         165 $i += 1;
1877             }
1878             }
1879              
1880             # quote metachar
1881 84         144 for (@singleoctet) {
1882 358 50       727 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1883 689         3009 $_ = '-';
1884             }
1885             elsif (/\A \n \z/oxms) {
1886 0         0 $_ = '\n';
1887             }
1888             elsif (/\A \r \z/oxms) {
1889 8         14 $_ = '\r';
1890             }
1891             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1892 8         19 $_ = sprintf('\x%02X', CORE::ord $1);
1893             }
1894             elsif (/\A [\x00-\xFF] \z/oxms) {
1895 60         204 $_ = quotemeta $_;
1896             }
1897             }
1898              
1899             # return character list
1900 429         714 return \@singleoctet, \@multipleoctet;
1901             }
1902              
1903             #
1904             # Latin-3 octal escape sequence
1905             #
1906             sub octchr {
1907 358     5 0 1188 my($octdigit) = @_;
1908              
1909 5         18 my @binary = ();
1910 5         11 for my $octal (split(//,$octdigit)) {
1911             push @binary, {
1912             '0' => '000',
1913             '1' => '001',
1914             '2' => '010',
1915             '3' => '011',
1916             '4' => '100',
1917             '5' => '101',
1918             '6' => '110',
1919             '7' => '111',
1920 5         74 }->{$octal};
1921             }
1922 50         196 my $binary = join '', @binary;
1923              
1924             my $octchr = {
1925             # 1234567
1926             1 => pack('B*', "0000000$binary"),
1927             2 => pack('B*', "000000$binary"),
1928             3 => pack('B*', "00000$binary"),
1929             4 => pack('B*', "0000$binary"),
1930             5 => pack('B*', "000$binary"),
1931             6 => pack('B*', "00$binary"),
1932             7 => pack('B*', "0$binary"),
1933             0 => pack('B*', "$binary"),
1934              
1935 5         16 }->{CORE::length($binary) % 8};
1936              
1937 5         234 return $octchr;
1938             }
1939              
1940             #
1941             # Latin-3 hexadecimal escape sequence
1942             #
1943             sub hexchr {
1944 5     5 0 25 my($hexdigit) = @_;
1945              
1946             my $hexchr = {
1947             1 => pack('H*', "0$hexdigit"),
1948             0 => pack('H*', "$hexdigit"),
1949              
1950 5         17 }->{CORE::length($_[0]) % 2};
1951              
1952 5         45 return $hexchr;
1953             }
1954              
1955             #
1956             # Latin-3 open character list for qr
1957             #
1958             sub charlist_qr {
1959              
1960 5     314 0 137 my $modifier = pop @_;
1961 314         624 my @char = @_;
1962              
1963 314         724 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1964 314         870 my @singleoctet = @$singleoctet;
1965 314         682 my @multipleoctet = @$multipleoctet;
1966              
1967             # return character list
1968 314 100       544 if (scalar(@singleoctet) >= 1) {
1969              
1970             # with /i modifier
1971 314 100       908 if ($modifier =~ m/i/oxms) {
1972 236         488 my %singleoctet_ignorecase = ();
1973 22         34 for (@singleoctet) {
1974 22   100     42 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1975 46         207 for my $ord (hex($1) .. hex($2)) {
1976 46         141 my $char = CORE::chr($ord);
1977 66         99 my $uc = Elatin3::uc($char);
1978 66         96 my $fc = Elatin3::fc($char);
1979 66 100       110 if ($uc eq $fc) {
1980 66         112 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1981             }
1982             else {
1983 12 50       89 if (CORE::length($fc) == 1) {
1984 54         87 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1985 54         111 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1986             }
1987             else {
1988 54         181 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1989 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1990             }
1991             }
1992             }
1993             }
1994 0 50       0 if ($_ ne '') {
1995 46         101 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1996             }
1997             }
1998 0         0 my $i = 0;
1999 22         32 my @singleoctet_ignorecase = ();
2000 22         33 for my $ord (0 .. 255) {
2001 22 100       33 if (exists $singleoctet_ignorecase{$ord}) {
2002 5632         11108 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         102  
2003             }
2004             else {
2005 96         225 $i++;
2006             }
2007             }
2008 5536         5489 @singleoctet = ();
2009 22         38 for my $range (@singleoctet_ignorecase) {
2010 22 100       63 if (ref $range) {
2011 3648 100       5701 if (scalar(@{$range}) == 1) {
  56 50       61  
2012 56         89 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         42  
2013             }
2014 36         128 elsif (scalar(@{$range}) == 2) {
2015 20         30 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2016             }
2017             else {
2018 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         24  
2019             }
2020             }
2021             }
2022             }
2023              
2024 20         70 my $not_anchor = '';
2025              
2026 236         369 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2027             }
2028 236 100       618 if (scalar(@multipleoctet) >= 2) {
2029 314         627 return '(?:' . join('|', @multipleoctet) . ')';
2030             }
2031             else {
2032 6         28 return $multipleoctet[0];
2033             }
2034             }
2035              
2036             #
2037             # Latin-3 open character list for not qr
2038             #
2039             sub charlist_not_qr {
2040              
2041 308     44 0 1277 my $modifier = pop @_;
2042 44         104 my @char = @_;
2043              
2044 44         109 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2045 44         113 my @singleoctet = @$singleoctet;
2046 44         94 my @multipleoctet = @$multipleoctet;
2047              
2048             # with /i modifier
2049 44 100       76 if ($modifier =~ m/i/oxms) {
2050 44         100 my %singleoctet_ignorecase = ();
2051 10         13 for (@singleoctet) {
2052 10   66     17 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2053 10         42 for my $ord (hex($1) .. hex($2)) {
2054 10         29 my $char = CORE::chr($ord);
2055 30         47 my $uc = Elatin3::uc($char);
2056 30         43 my $fc = Elatin3::fc($char);
2057 30 50       48 if ($uc eq $fc) {
2058 30         53 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2059             }
2060             else {
2061 0 50       0 if (CORE::length($fc) == 1) {
2062 30         41 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2063 30         61 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2064             }
2065             else {
2066 30         87 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2067 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2068             }
2069             }
2070             }
2071             }
2072 0 50       0 if ($_ ne '') {
2073 10         33 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2074             }
2075             }
2076 0         0 my $i = 0;
2077 10         12 my @singleoctet_ignorecase = ();
2078 10         15 for my $ord (0 .. 255) {
2079 10 100       14 if (exists $singleoctet_ignorecase{$ord}) {
2080 2560         2915 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         78  
2081             }
2082             else {
2083 60         131 $i++;
2084             }
2085             }
2086 2500         2513 @singleoctet = ();
2087 10         15 for my $range (@singleoctet_ignorecase) {
2088 10 100       25 if (ref $range) {
2089 960 50       1444 if (scalar(@{$range}) == 1) {
  20 50       21  
2090 20         28 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2091             }
2092 0         0 elsif (scalar(@{$range}) == 2) {
2093 20         24 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2094             }
2095             else {
2096 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         45  
  20         27  
2097             }
2098             }
2099             }
2100             }
2101              
2102             # return character list
2103 20 50       79 if (scalar(@multipleoctet) >= 1) {
2104 44 0       114 if (scalar(@singleoctet) >= 1) {
2105              
2106             # any character other than multiple-octet and single octet character class
2107 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2108             }
2109             else {
2110              
2111             # any character other than multiple-octet character class
2112 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2113             }
2114             }
2115             else {
2116 0 50       0 if (scalar(@singleoctet) >= 1) {
2117              
2118             # any character other than single octet character class
2119 44         95 return '(?:[^' . join('', @singleoctet) . '])';
2120             }
2121             else {
2122              
2123             # any character
2124 44         245 return "(?:$your_char)";
2125             }
2126             }
2127             }
2128              
2129             #
2130             # open file in read mode
2131             #
2132             sub _open_r {
2133 0     408   0 my(undef,$file) = @_;
2134 204     204   2094 use Fcntl qw(O_RDONLY);
  204         460  
  204         26718  
2135 408         1143 return CORE::sysopen($_[0], $file, &O_RDONLY);
2136             }
2137              
2138             #
2139             # open file in append mode
2140             #
2141             sub _open_a {
2142 408     204   17547 my(undef,$file) = @_;
2143 204     204   2360 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         465  
  204         598543  
2144 204         651 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2145             }
2146              
2147             #
2148             # safe system
2149             #
2150             sub _systemx {
2151              
2152             # P.707 29.2.33. exec
2153             # in Chapter 29: Functions
2154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2155             #
2156             # Be aware that in older releases of Perl, exec (and system) did not flush
2157             # your output buffer, so you needed to enable command buffering by setting $|
2158             # on one or more filehandles to avoid lost output in the case of exec, or
2159             # misordererd output in the case of system. This situation was largely remedied
2160             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2161              
2162             # P.855 exec
2163             # in Chapter 27: Functions
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165             #
2166             # In very old release of Perl (before v5.6), exec (and system) did not flush
2167             # your output buffer, so you needed to enable command buffering by setting $|
2168             # on one or more filehandles to avoid lost output with exec or misordered
2169             # output with system.
2170              
2171 204     204   33676 $| = 1;
2172              
2173             # P.565 23.1.2. Cleaning Up Your Environment
2174             # in Chapter 23: Security
2175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2176              
2177             # P.656 Cleaning Up Your Environment
2178             # in Chapter 20: Security
2179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2180              
2181             # local $ENV{'PATH'} = '.';
2182 204         748 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2183              
2184             # P.707 29.2.33. exec
2185             # in Chapter 29: Functions
2186             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2187             #
2188             # As we mentioned earlier, exec treats a discrete list of arguments as an
2189             # indication that it should bypass shell processing. However, there is one
2190             # place where you might still get tripped up. The exec call (and system, too)
2191             # will not distinguish between a single scalar argument and an array containing
2192             # only one element.
2193             #
2194             # @args = ("echo surprise"); # just one element in list
2195             # exec @args # still subject to shell escapes
2196             # or die "exec: $!"; # because @args == 1
2197             #
2198             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2199             # first argument as the pathname, which forces the rest of the arguments to be
2200             # interpreted as a list, even if there is only one of them:
2201             #
2202             # exec { $args[0] } @args # safe even with one-argument list
2203             # or die "can't exec @args: $!";
2204              
2205             # P.855 exec
2206             # in Chapter 27: Functions
2207             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2208             #
2209             # As we mentioned earlier, exec treats a discrete list of arguments as a
2210             # directive to bypass shell processing. However, there is one place where
2211             # you might still get tripped up. The exec call (and system, too) cannot
2212             # distinguish between a single scalar argument and an array containing
2213             # only one element.
2214             #
2215             # @args = ("echo surprise"); # just one element in list
2216             # exec @args # still subject to shell escapes
2217             # || die "exec: $!"; # because @args == 1
2218             #
2219             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2220             # argument as the pathname, which forces the rest of the arguments to be
2221             # interpreted as a list, even if there is only one of them:
2222             #
2223             # exec { $args[0] } @args # safe even with one-argument list
2224             # || die "can't exec @args: $!";
2225              
2226 204         1923 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         418  
2227             }
2228              
2229             #
2230             # Latin-3 order to character (with parameter)
2231             #
2232             sub Elatin3::chr(;$) {
2233              
2234 204 0   0 0 17700361 my $c = @_ ? $_[0] : $_;
2235              
2236 0 0       0 if ($c == 0x00) {
2237 0         0 return "\x00";
2238             }
2239             else {
2240 0         0 my @chr = ();
2241 0         0 while ($c > 0) {
2242 0         0 unshift @chr, ($c % 0x100);
2243 0         0 $c = int($c / 0x100);
2244             }
2245 0         0 return pack 'C*', @chr;
2246             }
2247             }
2248              
2249             #
2250             # Latin-3 order to character (without parameter)
2251             #
2252             sub Elatin3::chr_() {
2253              
2254 0     0 0 0 my $c = $_;
2255              
2256 0 0       0 if ($c == 0x00) {
2257 0         0 return "\x00";
2258             }
2259             else {
2260 0         0 my @chr = ();
2261 0         0 while ($c > 0) {
2262 0         0 unshift @chr, ($c % 0x100);
2263 0         0 $c = int($c / 0x100);
2264             }
2265 0         0 return pack 'C*', @chr;
2266             }
2267             }
2268              
2269             #
2270             # Latin-3 path globbing (with parameter)
2271             #
2272             sub Elatin3::glob($) {
2273              
2274 0 0   0 0 0 if (wantarray) {
2275 0         0 my @glob = _DOS_like_glob(@_);
2276 0         0 for my $glob (@glob) {
2277 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2278             }
2279 0         0 return @glob;
2280             }
2281             else {
2282 0         0 my $glob = _DOS_like_glob(@_);
2283 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2284 0         0 return $glob;
2285             }
2286             }
2287              
2288             #
2289             # Latin-3 path globbing (without parameter)
2290             #
2291             sub Elatin3::glob_() {
2292              
2293 0 0   0 0 0 if (wantarray) {
2294 0         0 my @glob = _DOS_like_glob();
2295 0         0 for my $glob (@glob) {
2296 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2297             }
2298 0         0 return @glob;
2299             }
2300             else {
2301 0         0 my $glob = _DOS_like_glob();
2302 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2303 0         0 return $glob;
2304             }
2305             }
2306              
2307             #
2308             # Latin-3 path globbing via File::DosGlob 1.10
2309             #
2310             # Often I confuse "_dosglob" and "_doglob".
2311             # So, I renamed "_dosglob" to "_DOS_like_glob".
2312             #
2313             my %iter;
2314             my %entries;
2315             sub _DOS_like_glob {
2316              
2317             # context (keyed by second cxix argument provided by core)
2318 0     0   0 my($expr,$cxix) = @_;
2319              
2320             # glob without args defaults to $_
2321 0 0       0 $expr = $_ if not defined $expr;
2322              
2323             # represents the current user's home directory
2324             #
2325             # 7.3. Expanding Tildes in Filenames
2326             # in Chapter 7. File Access
2327             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2328             #
2329             # and File::HomeDir, File::HomeDir::Windows module
2330              
2331             # DOS-like system
2332 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2333 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2334             { my_home_MSWin32() }oxmse;
2335             }
2336              
2337             # UNIX-like system
2338 0 0 0     0 else {
  0         0  
2339             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2340             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2341             }
2342 0 0       0  
2343 0 0       0 # assume global context if not provided one
2344             $cxix = '_G_' if not defined $cxix;
2345             $iter{$cxix} = 0 if not exists $iter{$cxix};
2346 0 0       0  
2347 0         0 # if we're just beginning, do it all first
2348             if ($iter{$cxix} == 0) {
2349             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2350             }
2351 0 0       0  
2352 0         0 # chuck it all out, quick or slow
2353 0         0 if (wantarray) {
  0         0  
2354             delete $iter{$cxix};
2355             return @{delete $entries{$cxix}};
2356 0 0       0 }
  0         0  
2357 0         0 else {
  0         0  
2358             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2359             return shift @{$entries{$cxix}};
2360             }
2361 0         0 else {
2362 0         0 # return undef for EOL
2363 0         0 delete $iter{$cxix};
2364             delete $entries{$cxix};
2365             return undef;
2366             }
2367             }
2368             }
2369              
2370             #
2371             # Latin-3 path globbing subroutine
2372             #
2373 0     0   0 sub _do_glob {
2374 0         0  
2375 0         0 my($cond,@expr) = @_;
2376             my @glob = ();
2377             my $fix_drive_relative_paths = 0;
2378 0         0  
2379 0 0       0 OUTER:
2380 0 0       0 for my $expr (@expr) {
2381             next OUTER if not defined $expr;
2382 0         0 next OUTER if $expr eq '';
2383 0         0  
2384 0         0 my @matched = ();
2385 0         0 my @globdir = ();
2386 0         0 my $head = '.';
2387             my $pathsep = '/';
2388             my $tail;
2389 0 0       0  
2390 0         0 # if argument is within quotes strip em and do no globbing
2391 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2392 0 0       0 $expr = $1;
2393 0         0 if ($cond eq 'd') {
2394             if (-d $expr) {
2395             push @glob, $expr;
2396             }
2397 0 0       0 }
2398 0         0 else {
2399             if (-e $expr) {
2400             push @glob, $expr;
2401 0         0 }
2402             }
2403             next OUTER;
2404             }
2405              
2406 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2407 0 0       0 # to h:./*.pm to expand correctly
2408 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2409             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2410             $fix_drive_relative_paths = 1;
2411             }
2412 0 0       0 }
2413 0 0       0  
2414 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2415 0         0 if ($tail eq '') {
2416             push @glob, $expr;
2417 0 0       0 next OUTER;
2418 0 0       0 }
2419 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2420 0         0 if (@globdir = _do_glob('d', $head)) {
2421             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2422             next OUTER;
2423 0 0 0     0 }
2424 0         0 }
2425             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2426 0         0 $head .= $pathsep;
2427             }
2428             $expr = $tail;
2429             }
2430 0 0       0  
2431 0 0       0 # If file component has no wildcards, we can avoid opendir
2432 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2433             if ($head eq '.') {
2434 0 0 0     0 $head = '';
2435 0         0 }
2436             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2437 0         0 $head .= $pathsep;
2438 0 0       0 }
2439 0 0       0 $head .= $expr;
2440 0         0 if ($cond eq 'd') {
2441             if (-d $head) {
2442             push @glob, $head;
2443             }
2444 0 0       0 }
2445 0         0 else {
2446             if (-e $head) {
2447             push @glob, $head;
2448 0         0 }
2449             }
2450 0 0       0 next OUTER;
2451 0         0 }
2452 0         0 opendir(*DIR, $head) or next OUTER;
2453             my @leaf = readdir DIR;
2454 0 0       0 closedir DIR;
2455 0         0  
2456             if ($head eq '.') {
2457 0 0 0     0 $head = '';
2458 0         0 }
2459             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2460             $head .= $pathsep;
2461 0         0 }
2462 0         0  
2463 0         0 my $pattern = '';
2464             while ($expr =~ / \G ($q_char) /oxgc) {
2465             my $char = $1;
2466              
2467             # 6.9. Matching Shell Globs as Regular Expressions
2468             # in Chapter 6. Pattern Matching
2469             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2470 0 0       0 # (and so on)
    0          
    0          
2471 0         0  
2472             if ($char eq '*') {
2473             $pattern .= "(?:$your_char)*",
2474 0         0 }
2475             elsif ($char eq '?') {
2476             $pattern .= "(?:$your_char)?", # DOS style
2477             # $pattern .= "(?:$your_char)", # UNIX style
2478 0         0 }
2479             elsif ((my $fc = Elatin3::fc($char)) ne $char) {
2480             $pattern .= $fc;
2481 0         0 }
2482             else {
2483             $pattern .= quotemeta $char;
2484 0     0   0 }
  0         0  
2485             }
2486             my $matchsub = sub { Elatin3::fc($_[0]) =~ /\A $pattern \z/xms };
2487              
2488             # if ($@) {
2489             # print STDERR "$0: $@\n";
2490             # next OUTER;
2491             # }
2492 0         0  
2493 0 0 0     0 INNER:
2494 0         0 for my $leaf (@leaf) {
2495             if ($leaf eq '.' or $leaf eq '..') {
2496 0 0 0     0 next INNER;
2497 0         0 }
2498             if ($cond eq 'd' and not -d "$head$leaf") {
2499             next INNER;
2500 0 0       0 }
2501 0         0  
2502 0         0 if (&$matchsub($leaf)) {
2503             push @matched, "$head$leaf";
2504             next INNER;
2505             }
2506              
2507             # [DOS compatibility special case]
2508 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2509              
2510             if (Elatin3::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2511             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2512 0 0       0 Elatin3::index($pattern,'\\.') != -1 # pattern has a dot.
2513 0         0 ) {
2514 0         0 if (&$matchsub("$leaf.")) {
2515             push @matched, "$head$leaf";
2516             next INNER;
2517             }
2518 0 0       0 }
2519 0         0 }
2520             if (@matched) {
2521             push @glob, @matched;
2522 0 0       0 }
2523 0         0 }
2524 0         0 if ($fix_drive_relative_paths) {
2525             for my $glob (@glob) {
2526             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2527 0         0 }
2528             }
2529             return @glob;
2530             }
2531              
2532             #
2533             # Latin-3 parse line
2534             #
2535 0     0   0 sub _parse_line {
2536              
2537 0         0 my($line) = @_;
2538 0         0  
2539 0         0 $line .= ' ';
2540             my @piece = ();
2541             while ($line =~ /
2542             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2543             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2544 0 0       0 /oxmsg
2545             ) {
2546 0         0 push @piece, defined($1) ? $1 : $2;
2547             }
2548             return @piece;
2549             }
2550              
2551             #
2552             # Latin-3 parse path
2553             #
2554 0     0   0 sub _parse_path {
2555              
2556 0         0 my($path,$pathsep) = @_;
2557 0         0  
2558 0         0 $path .= '/';
2559             my @subpath = ();
2560             while ($path =~ /
2561             ((?: [^\/\\] )+?) [\/\\]
2562 0         0 /oxmsg
2563             ) {
2564             push @subpath, $1;
2565 0         0 }
2566 0         0  
2567 0         0 my $tail = pop @subpath;
2568             my $head = join $pathsep, @subpath;
2569             return $head, $tail;
2570             }
2571              
2572             #
2573             # via File::HomeDir::Windows 1.00
2574             #
2575             sub my_home_MSWin32 {
2576              
2577             # A lot of unix people and unix-derived tools rely on
2578 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2579 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2580             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2581             return $ENV{'HOME'};
2582             }
2583              
2584 0         0 # Do we have a user profile?
2585             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2586             return $ENV{'USERPROFILE'};
2587             }
2588              
2589 0         0 # Some Windows use something like $ENV{'HOME'}
2590             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2591             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2592 0         0 }
2593              
2594             return undef;
2595             }
2596              
2597             #
2598             # via File::HomeDir::Unix 1.00
2599 0     0 0 0 #
2600             sub my_home {
2601 0 0 0     0 my $home;
    0 0        
2602 0         0  
2603             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2604             $home = $ENV{'HOME'};
2605             }
2606              
2607             # This is from the original code, but I'm guessing
2608 0         0 # it means "login directory" and exists on some Unixes.
2609             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2610             $home = $ENV{'LOGDIR'};
2611             }
2612              
2613             ### More-desperate methods
2614              
2615 0         0 # Light desperation on any (Unixish) platform
2616             else {
2617             $home = CORE::eval q{ (getpwuid($<))[7] };
2618             }
2619              
2620 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2621 0         0 # For example, "nobody"-like users might use /nonexistant
2622             if (defined $home and ! -d($home)) {
2623 0         0 $home = undef;
2624             }
2625             return $home;
2626             }
2627              
2628             #
2629             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2630 0     0 0 0 #
2631             sub Elatin3::PREMATCH {
2632             return $`;
2633             }
2634              
2635             #
2636             # ${^MATCH}, $MATCH, $& the string that matched
2637 0     0 0 0 #
2638             sub Elatin3::MATCH {
2639             return $&;
2640             }
2641              
2642             #
2643             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2644 0     0 0 0 #
2645             sub Elatin3::POSTMATCH {
2646             return $';
2647             }
2648              
2649             #
2650             # Latin-3 character to order (with parameter)
2651             #
2652 0 0   0 1 0 sub Latin3::ord(;$) {
2653              
2654 0 0       0 local $_ = shift if @_;
2655 0         0  
2656 0         0 if (/\A ($q_char) /oxms) {
2657 0         0 my @ord = unpack 'C*', $1;
2658 0         0 my $ord = 0;
2659             while (my $o = shift @ord) {
2660 0         0 $ord = $ord * 0x100 + $o;
2661             }
2662             return $ord;
2663 0         0 }
2664             else {
2665             return CORE::ord $_;
2666             }
2667             }
2668              
2669             #
2670             # Latin-3 character to order (without parameter)
2671             #
2672 0 0   0 0 0 sub Latin3::ord_() {
2673 0         0  
2674 0         0 if (/\A ($q_char) /oxms) {
2675 0         0 my @ord = unpack 'C*', $1;
2676 0         0 my $ord = 0;
2677             while (my $o = shift @ord) {
2678 0         0 $ord = $ord * 0x100 + $o;
2679             }
2680             return $ord;
2681 0         0 }
2682             else {
2683             return CORE::ord $_;
2684             }
2685             }
2686              
2687             #
2688             # Latin-3 reverse
2689             #
2690 0 0   0 0 0 sub Latin3::reverse(@) {
2691 0         0  
2692             if (wantarray) {
2693             return CORE::reverse @_;
2694             }
2695             else {
2696              
2697             # One of us once cornered Larry in an elevator and asked him what
2698             # problem he was solving with this, but he looked as far off into
2699             # the distance as he could in an elevator and said, "It seemed like
2700 0         0 # a good idea at the time."
2701              
2702             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2703             }
2704             }
2705              
2706             #
2707             # Latin-3 getc (with parameter, without parameter)
2708             #
2709 0     0 0 0 sub Latin3::getc(;*@) {
2710 0 0       0  
2711 0 0 0     0 my($package) = caller;
2712             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2713 0         0 croak 'Too many arguments for Latin3::getc' if @_ and not wantarray;
  0         0  
2714 0         0  
2715 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2716 0         0 my $getc = '';
2717 0 0       0 for my $length ($length[0] .. $length[-1]) {
2718 0 0       0 $getc .= CORE::getc($fh);
2719 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2720             if ($getc =~ /\A ${Elatin3::dot_s} \z/oxms) {
2721             return wantarray ? ($getc,@_) : $getc;
2722             }
2723 0 0       0 }
2724             }
2725             return wantarray ? ($getc,@_) : $getc;
2726             }
2727              
2728             #
2729             # Latin-3 length by character
2730             #
2731 0 0   0 1 0 sub Latin3::length(;$) {
2732              
2733 0         0 local $_ = shift if @_;
2734 0         0  
2735             local @_ = /\G ($q_char) /oxmsg;
2736             return scalar @_;
2737             }
2738              
2739             #
2740             # Latin-3 substr by character
2741             #
2742             BEGIN {
2743              
2744             # P.232 The lvalue Attribute
2745             # in Chapter 6: Subroutines
2746             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2747              
2748             # P.336 The lvalue Attribute
2749             # in Chapter 7: Subroutines
2750             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2751              
2752             # P.144 8.4 Lvalue subroutines
2753             # in Chapter 8: perlsub: Perl subroutines
2754 204 50 0 204 1 116781 # 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  
2755              
2756             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2757             # vv----------------------*******
2758             sub Latin3::substr($$;$$) %s {
2759              
2760             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2761              
2762             # If the substring is beyond either end of the string, substr() returns the undefined
2763             # value and produces a warning. When used as an lvalue, specifying a substring that
2764             # is entirely outside the string raises an exception.
2765             # http://perldoc.perl.org/functions/substr.html
2766              
2767             # A return with no argument returns the scalar value undef in scalar context,
2768             # an empty list () in list context, and (naturally) nothing at all in void
2769             # context.
2770              
2771             my $offset = $_[1];
2772             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2773             return;
2774             }
2775              
2776             # substr($string,$offset,$length,$replacement)
2777             if (@_ == 4) {
2778             my(undef,undef,$length,$replacement) = @_;
2779             my $substr = join '', splice(@char, $offset, $length, $replacement);
2780             $_[0] = join '', @char;
2781              
2782             # return $substr; this doesn't work, don't say "return"
2783             $substr;
2784             }
2785              
2786             # substr($string,$offset,$length)
2787             elsif (@_ == 3) {
2788             my(undef,undef,$length) = @_;
2789             my $octet_offset = 0;
2790             my $octet_length = 0;
2791             if ($offset == 0) {
2792             $octet_offset = 0;
2793             }
2794             elsif ($offset > 0) {
2795             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2796             }
2797             else {
2798             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2799             }
2800             if ($length == 0) {
2801             $octet_length = 0;
2802             }
2803             elsif ($length > 0) {
2804             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2805             }
2806             else {
2807             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset, $octet_length);
2810             }
2811              
2812             # substr($string,$offset)
2813             else {
2814             my $octet_offset = 0;
2815             if ($offset == 0) {
2816             $octet_offset = 0;
2817             }
2818             elsif ($offset > 0) {
2819             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2820             }
2821             else {
2822             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2823             }
2824             CORE::substr($_[0], $octet_offset);
2825             }
2826             }
2827             END
2828             }
2829              
2830             #
2831             # Latin-3 index by character
2832             #
2833 0     0 1 0 sub Latin3::index($$;$) {
2834 0 0       0  
2835 0         0 my $index;
2836             if (@_ == 3) {
2837             $index = Elatin3::index($_[0], $_[1], CORE::length(Latin3::substr($_[0], 0, $_[2])));
2838 0         0 }
2839             else {
2840             $index = Elatin3::index($_[0], $_[1]);
2841 0 0       0 }
2842 0         0  
2843             if ($index == -1) {
2844             return -1;
2845 0         0 }
2846             else {
2847             return Latin3::length(CORE::substr $_[0], 0, $index);
2848             }
2849             }
2850              
2851             #
2852             # Latin-3 rindex by character
2853             #
2854 0     0 1 0 sub Latin3::rindex($$;$) {
2855 0 0       0  
2856 0         0 my $rindex;
2857             if (@_ == 3) {
2858             $rindex = Elatin3::rindex($_[0], $_[1], CORE::length(Latin3::substr($_[0], 0, $_[2])));
2859 0         0 }
2860             else {
2861             $rindex = Elatin3::rindex($_[0], $_[1]);
2862 0 0       0 }
2863 0         0  
2864             if ($rindex == -1) {
2865             return -1;
2866 0         0 }
2867             else {
2868             return Latin3::length(CORE::substr $_[0], 0, $rindex);
2869             }
2870             }
2871              
2872 204     204   1765 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         571  
  204         41993  
2873             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2874             use vars qw($slash); $slash = 'm//';
2875              
2876             # ord() to ord() or Latin3::ord()
2877             my $function_ord = 'ord';
2878              
2879             # ord to ord or Latin3::ord_
2880             my $function_ord_ = 'ord';
2881              
2882             # reverse to reverse or Latin3::reverse
2883             my $function_reverse = 'reverse';
2884              
2885             # getc to getc or Latin3::getc
2886             my $function_getc = 'getc';
2887              
2888             # P.1023 Appendix W.9 Multibyte Anchoring
2889             # of ISBN 1-56592-224-7 CJKV Information Processing
2890              
2891 204     204   1674 my $anchor = '';
  204     0   494  
  204         9089903  
2892              
2893             use vars qw($nest);
2894              
2895             # regexp of nested parens in qqXX
2896              
2897             # P.340 Matching Nested Constructs with Embedded Code
2898             # in Chapter 7: Perl
2899             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2900              
2901             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2902             [^\\()] |
2903             \( (?{$nest++}) |
2904             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2905             \\ [^c] |
2906             \\c[\x40-\x5F] |
2907             [\x00-\xFF]
2908             }xms;
2909              
2910             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2911             [^\\{}] |
2912             \{ (?{$nest++}) |
2913             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2914             \\ [^c] |
2915             \\c[\x40-\x5F] |
2916             [\x00-\xFF]
2917             }xms;
2918              
2919             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2920             [^\\\[\]] |
2921             \[ (?{$nest++}) |
2922             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2923             \\ [^c] |
2924             \\c[\x40-\x5F] |
2925             [\x00-\xFF]
2926             }xms;
2927              
2928             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2929             [^\\<>] |
2930             \< (?{$nest++}) |
2931             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2932             \\ [^c] |
2933             \\c[\x40-\x5F] |
2934             [\x00-\xFF]
2935             }xms;
2936              
2937             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2938             (?: ::)? (?:
2939             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2940             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2941             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2942             ))
2943             }xms;
2944              
2945             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2946             (?: ::)? (?:
2947             (?>[0-9]+) |
2948             [^a-zA-Z_0-9\[\]] |
2949             ^[A-Z] |
2950             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2951             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2952             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2953             ))
2954             }xms;
2955              
2956             my $qq_substr = qr{(?> Char::substr | Latin3::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2957             }xms;
2958              
2959             # regexp of nested parens in qXX
2960             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2961             [^()] |
2962             \( (?{$nest++}) |
2963             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2964             [\x00-\xFF]
2965             }xms;
2966              
2967             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2968             [^\{\}] |
2969             \{ (?{$nest++}) |
2970             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2971             [\x00-\xFF]
2972             }xms;
2973              
2974             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2975             [^\[\]] |
2976             \[ (?{$nest++}) |
2977             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2978             [\x00-\xFF]
2979             }xms;
2980              
2981             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2982             [^<>] |
2983             \< (?{$nest++}) |
2984             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2985             [\x00-\xFF]
2986             }xms;
2987              
2988             my $matched = '';
2989             my $s_matched = '';
2990              
2991             my $tr_variable = ''; # variable of tr///
2992             my $sub_variable = ''; # variable of s///
2993             my $bind_operator = ''; # =~ or !~
2994              
2995             my @heredoc = (); # here document
2996             my @heredoc_delimiter = ();
2997             my $here_script = ''; # here script
2998              
2999             #
3000             # escape Latin-3 script
3001 0 50   204 0 0 #
3002             sub Latin3::escape(;$) {
3003             local($_) = $_[0] if @_;
3004              
3005             # P.359 The Study Function
3006             # in Chapter 7: Perl
3007 204         641 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3008              
3009             study $_; # Yes, I studied study yesterday.
3010              
3011             # while all script
3012              
3013             # 6.14. Matching from Where the Last Pattern Left Off
3014             # in Chapter 6. Pattern Matching
3015             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3016             # (and so on)
3017              
3018             # one member of Tag-team
3019             #
3020             # P.128 Start of match (or end of previous match): \G
3021             # P.130 Advanced Use of \G with Perl
3022             # in Chapter 3: Overview of Regular Expression Features and Flavors
3023             # P.255 Use leading anchors
3024             # P.256 Expose ^ and \G at the front expressions
3025             # in Chapter 6: Crafting an Efficient Expression
3026             # P.315 "Tag-team" matching with /gc
3027             # in Chapter 7: Perl
3028 204         418 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3029 204         360  
3030 204         810 my $e_script = '';
3031             while (not /\G \z/oxgc) { # member
3032             $e_script .= Latin3::escape_token();
3033 74843         110602 }
3034              
3035             return $e_script;
3036             }
3037              
3038             #
3039             # escape Latin-3 token of script
3040             #
3041             sub Latin3::escape_token {
3042              
3043 204     74843 0 2652 # \n output here document
3044              
3045             my $ignore_modules = join('|', qw(
3046             utf8
3047             bytes
3048             charnames
3049             I18N::Japanese
3050             I18N::Collate
3051             I18N::JExt
3052             File::DosGlob
3053             Wild
3054             Wildcard
3055             Japanese
3056             ));
3057              
3058             # another member of Tag-team
3059             #
3060             # P.315 "Tag-team" matching with /gc
3061             # in Chapter 7: Perl
3062 74843 100 100     92240 # 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          
3063 74843         2861124  
3064 12529 100       16099 if (/\G ( \n ) /oxgc) { # another member (and so on)
3065 12529         39082 my $heredoc = '';
3066             if (scalar(@heredoc_delimiter) >= 1) {
3067 174         231 $slash = 'm//';
3068 174         827  
3069             $heredoc = join '', @heredoc;
3070             @heredoc = ();
3071 174         340  
3072 174         314 # skip here document
3073             for my $heredoc_delimiter (@heredoc_delimiter) {
3074 174         1156 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3075             }
3076 174         495 @heredoc_delimiter = ();
3077              
3078 174         304 $here_script = '';
3079             }
3080             return "\n" . $heredoc;
3081             }
3082 12529         36746  
3083             # ignore space, comment
3084             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3085              
3086             # if (, elsif (, unless (, while (, until (, given (, and when (
3087              
3088             # given, when
3089              
3090             # P.225 The given Statement
3091             # in Chapter 15: Smart Matching and given-when
3092             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3093              
3094             # P.133 The given Statement
3095             # in Chapter 4: Statements and Declarations
3096             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3097 17961         56337  
3098 1401         2194 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3099             $slash = 'm//';
3100             return $1;
3101             }
3102              
3103             # scalar variable ($scalar = ...) =~ tr///;
3104             # scalar variable ($scalar = ...) =~ s///;
3105              
3106             # state
3107              
3108             # P.68 Persistent, Private Variables
3109             # in Chapter 4: Subroutines
3110             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3111              
3112             # P.160 Persistent Lexically Scoped Variables: state
3113             # in Chapter 4: Statements and Declarations
3114             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3115              
3116             # (and so on)
3117 1401         4245  
3118             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3119 86 50       180 my $e_string = e_string($1);
    50          
3120 86         2024  
3121 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3122 0         0 $tr_variable = $e_string . e_string($1);
3123 0         0 $bind_operator = $2;
3124             $slash = 'm//';
3125             return '';
3126 0         0 }
3127 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3128 0         0 $sub_variable = $e_string . e_string($1);
3129 0         0 $bind_operator = $2;
3130             $slash = 'm//';
3131             return '';
3132 0         0 }
3133 86         151 else {
3134             $slash = 'div';
3135             return $e_string;
3136             }
3137             }
3138              
3139 86         282 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin3::PREMATCH()
3140 4         7 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3141             $slash = 'div';
3142             return q{Elatin3::PREMATCH()};
3143             }
3144              
3145 4         14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin3::MATCH()
3146 28         47 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3147             $slash = 'div';
3148             return q{Elatin3::MATCH()};
3149             }
3150              
3151 28         90 # $', ${'} --> $', ${'}
3152 1         3 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3153             $slash = 'div';
3154             return $1;
3155             }
3156              
3157 1         5 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin3::POSTMATCH()
3158 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3159             $slash = 'div';
3160             return q{Elatin3::POSTMATCH()};
3161             }
3162              
3163             # scalar variable $scalar =~ tr///;
3164             # scalar variable $scalar =~ s///;
3165             # substr() =~ tr///;
3166 3         10 # substr() =~ s///;
3167             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3168 1671 100       3897 my $scalar = e_string($1);
    100          
3169 1671         6565  
3170 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3171 1         3 $tr_variable = $scalar;
3172 1         3 $bind_operator = $1;
3173             $slash = 'm//';
3174             return '';
3175 1         3 }
3176 61         113 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3177 61         120 $sub_variable = $scalar;
3178 61         84 $bind_operator = $1;
3179             $slash = 'm//';
3180             return '';
3181 61         168 }
3182 1609         2141 else {
3183             $slash = 'div';
3184             return $scalar;
3185             }
3186             }
3187              
3188 1609         3997 # end of statement
3189             elsif (/\G ( [,;] ) /oxgc) {
3190             $slash = 'm//';
3191 4991         7304  
3192             # clear tr/// variable
3193             $tr_variable = '';
3194 4991         5779  
3195             # clear s/// variable
3196 4991         5516 $sub_variable = '';
3197              
3198 4991         5337 $bind_operator = '';
3199              
3200             return $1;
3201             }
3202              
3203 4991         16389 # bareword
3204             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3205             return $1;
3206             }
3207              
3208 0         0 # $0 --> $0
3209 2         12 elsif (/\G ( \$ 0 ) /oxmsgc) {
3210             $slash = 'div';
3211             return $1;
3212 2         9 }
3213 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3214             $slash = 'div';
3215             return $1;
3216             }
3217              
3218 0         0 # $$ --> $$
3219 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3220             $slash = 'div';
3221             return $1;
3222             }
3223              
3224             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3225 1         3 # $1, $2, $3 --> $1, $2, $3 otherwise
3226 4         8 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3227             $slash = 'div';
3228             return e_capture($1);
3229 4         6 }
3230 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3231             $slash = 'div';
3232             return e_capture($1);
3233             }
3234              
3235 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3236 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3237             $slash = 'div';
3238             return e_capture($1.'->'.$2);
3239             }
3240              
3241 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3242 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3243             $slash = 'div';
3244             return e_capture($1.'->'.$2);
3245             }
3246              
3247 0         0 # $$foo
3248 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3249             $slash = 'div';
3250             return e_capture($1);
3251             }
3252              
3253 0         0 # ${ foo }
3254 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3255             $slash = 'div';
3256             return '${' . $1 . '}';
3257             }
3258              
3259 0         0 # ${ ... }
3260 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3261             $slash = 'div';
3262             return e_capture($1);
3263             }
3264              
3265             # variable or function
3266 0         0 # $ @ % & * $ #
3267 42         71 elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
3268             $slash = 'div';
3269             return $1;
3270             }
3271             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3272 42         134 # $ @ # \ ' " / ? ( ) [ ] < >
3273 62         118 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3274             $slash = 'div';
3275             return $1;
3276             }
3277              
3278 62         202 # while ()
3279             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3280             return $1;
3281             }
3282              
3283             # while () --- glob
3284              
3285             # avoid "Error: Runtime exception" of perl version 5.005_03
3286 0         0  
3287             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3288             return 'while ($_ = Elatin3::glob("' . $1 . '"))';
3289             }
3290              
3291 0         0 # while (glob)
3292             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3293             return 'while ($_ = Elatin3::glob_)';
3294             }
3295              
3296 0         0 # while (glob(WILDCARD))
3297             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3298             return 'while ($_ = Elatin3::glob';
3299             }
3300 0         0  
  248         518  
3301             # doit if, doit unless, doit while, doit until, doit for, doit when
3302             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3303 248         874  
  19         34  
3304 19         64 # subroutines of package Elatin3
  0         0  
3305 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         17  
3306 13         34 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3307 0         0 elsif (/\G \b Latin3::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         172  
3308 114         329 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
3309 2         6 elsif (/\G \b Latin3::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin3::escape'; }
  0         0  
3310 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
3311 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::chop'; }
  0         0  
3312 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3313 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3314 0         0 elsif (/\G \b Latin3::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin3::index'; }
  2         13  
3315 2         12 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::index'; }
  0         0  
3316 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3317 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3318 0         0 elsif (/\G \b Latin3::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin3::rindex'; }
  1         3  
3319 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::rindex'; }
  0         0  
3320 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin3::lc'; }
  1         3  
3321 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin3::lcfirst'; }
  0         0  
3322 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin3::uc'; }
  6         13  
3323             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin3::ucfirst'; }
3324             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin3::fc'; }
3325 6         17  
  0         0  
3326 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3327 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3328 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3329 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3330 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3331 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3332             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3333 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  
3334 0         0  
  0         0  
3335 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3336 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3337 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3338 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3339 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3340             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3341             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3342 0         0  
  0         0  
3343 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3344 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3345 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3346             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3347 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3348 2         7  
  2         4  
3349 2         6 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         71  
3350 36         113 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3351 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin3::chr'; }
  8         13  
3352 8         24 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3353 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3354 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin3::glob'; }
  0         0  
3355 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::lc_'; }
  0         0  
3356 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::lcfirst_'; }
  0         0  
3357 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::uc_'; }
  0         0  
3358 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::ucfirst_'; }
  0         0  
3359             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::fc_'; }
3360 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3361 0         0  
  0         0  
3362 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3363 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3364 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::chr_'; }
  0         0  
3365 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3366 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3367 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin3::glob_'; }
  8         18  
3368             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3369             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3370 8         28 # split
3371             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3372 87         220 $slash = 'm//';
3373 87         137  
3374 87         315 my $e = '';
3375             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3376             $e .= $1;
3377             }
3378 85 100       304  
  87 100       5795  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3379             # end of split
3380             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin3::split' . $e; }
3381 2         9  
3382             # split scalar value
3383             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin3::split' . $e . e_string($1); }
3384 1         6  
3385 0         0 # split literal space
3386 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin3::split' . $e . qq {qq$1 $2}; }
3387 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin3::split' . $e . qq{$1qq$2 $3}; }
3388 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin3::split' . $e . qq{$1qq$2 $3}; }
3389 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin3::split' . $e . qq{$1qq$2 $3}; }
3390 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin3::split' . $e . qq{$1qq$2 $3}; }
3391 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin3::split' . $e . qq{$1qq$2 $3}; }
3392 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin3::split' . $e . qq {q$1 $2}; }
3393 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin3::split' . $e . qq {$1q$2 $3}; }
3394 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin3::split' . $e . qq {$1q$2 $3}; }
3395 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin3::split' . $e . qq {$1q$2 $3}; }
3396 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin3::split' . $e . qq {$1q$2 $3}; }
3397 10         40 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin3::split' . $e . qq {$1q$2 $3}; }
3398             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin3::split' . $e . qq {' '}; }
3399             elsif (/\G " [ ] " /oxgc) { return 'Elatin3::split' . $e . qq {" "}; }
3400              
3401 0 0       0 # split qq//
  0         0  
3402             elsif (/\G \b (qq) \b /oxgc) {
3403 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3404 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3405 0         0 while (not /\G \z/oxgc) {
3406 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3407 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3408 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3409 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3410 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3411             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3412 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3413             }
3414             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3415             }
3416             }
3417              
3418 0 50       0 # split qr//
  12         407  
3419             elsif (/\G \b (qr) \b /oxgc) {
3420 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3421 12 50       62 else {
  12 50       3145  
    50          
    50          
    50          
    50          
    50          
    50          
3422 0         0 while (not /\G \z/oxgc) {
3423 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3424 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3425 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3426 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3427 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3428 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3429             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3430 12         80 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3431             }
3432             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3433             }
3434             }
3435              
3436 0 0       0 # split q//
  0         0  
3437             elsif (/\G \b (q) \b /oxgc) {
3438 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3439 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3440 0         0 while (not /\G \z/oxgc) {
3441 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3442 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3443 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3444 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3445 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3446             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3447 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3448             }
3449             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3450             }
3451             }
3452              
3453 0 50       0 # split m//
  18         922  
3454             elsif (/\G \b (m) \b /oxgc) {
3455 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3456 18 50       80 else {
  18 50       3865  
    50          
    50          
    50          
    50          
    50          
    50          
3457 0         0 while (not /\G \z/oxgc) {
3458 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3459 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3460 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3461 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3462 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3463 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3464             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3465 18         102 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3466             }
3467             die __FILE__, ": Search pattern not terminated\n";
3468             }
3469             }
3470              
3471 0         0 # split ''
3472 0         0 elsif (/\G (\') /oxgc) {
3473 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3474 0         0 while (not /\G \z/oxgc) {
3475 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3476 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3477             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3478 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3479             }
3480             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3481             }
3482              
3483 0         0 # split ""
3484 0         0 elsif (/\G (\") /oxgc) {
3485 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3486 0         0 while (not /\G \z/oxgc) {
3487 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3488 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3489             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3490 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3491             }
3492             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3493             }
3494              
3495 0         0 # split //
3496 44         111 elsif (/\G (\/) /oxgc) {
3497 44 50       156 my $regexp = '';
  381 50       1551  
    100          
    50          
3498 0         0 while (not /\G \z/oxgc) {
3499 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3500 44         183 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3501             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3502 337         682 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3503             }
3504             die __FILE__, ": Search pattern not terminated\n";
3505             }
3506             }
3507              
3508             # tr/// or y///
3509              
3510             # about [cdsrbB]* (/B modifier)
3511             #
3512             # P.559 appendix C
3513             # of ISBN 4-89052-384-7 Programming perl
3514             # (Japanese title is: Perl puroguramingu)
3515 0         0  
3516             elsif (/\G \b ( tr | y ) \b /oxgc) {
3517             my $ope = $1;
3518 3 50       7  
3519 3         55 # $1 $2 $3 $4 $5 $6
3520 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3521             my @tr = ($tr_variable,$2);
3522             return e_tr(@tr,'',$4,$6);
3523 0         0 }
3524 3         9 else {
3525 3 50       12 my $e = '';
  3 50       240  
    50          
    50          
    50          
    50          
3526             while (not /\G \z/oxgc) {
3527 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3528 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3529 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3530 0         0 while (not /\G \z/oxgc) {
3531 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3532 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3533 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3534 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3535             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3536 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3537             }
3538             die __FILE__, ": Transliteration replacement not terminated\n";
3539 0         0 }
3540 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3541 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3542 0         0 while (not /\G \z/oxgc) {
3543 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3544 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3545 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3546 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3547             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3548 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3549             }
3550             die __FILE__, ": Transliteration replacement not terminated\n";
3551 0         0 }
3552 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3553 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3554 0         0 while (not /\G \z/oxgc) {
3555 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3556 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3557 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3558 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3559             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3560 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3561             }
3562             die __FILE__, ": Transliteration replacement not terminated\n";
3563 0         0 }
3564 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3565 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3566 0         0 while (not /\G \z/oxgc) {
3567 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3568 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3569 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3570 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3571             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3572 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3573             }
3574             die __FILE__, ": Transliteration replacement not terminated\n";
3575             }
3576 0         0 # $1 $2 $3 $4 $5 $6
3577 3         14 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3578             my @tr = ($tr_variable,$2);
3579             return e_tr(@tr,'',$4,$6);
3580 3         13 }
3581             }
3582             die __FILE__, ": Transliteration pattern not terminated\n";
3583             }
3584             }
3585              
3586 0         0 # qq//
3587             elsif (/\G \b (qq) \b /oxgc) {
3588             my $ope = $1;
3589 2180 50       4679  
3590 2180         3936 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3591 0         0 if (/\G (\#) /oxgc) { # qq# #
3592 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3593 0         0 while (not /\G \z/oxgc) {
3594 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3595 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3596             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3597 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3598             }
3599             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3600             }
3601 0         0  
3602 2180         2839 else {
3603 2180 50       6197 my $e = '';
  2180 50       8106  
    100          
    50          
    50          
    0          
3604             while (not /\G \z/oxgc) {
3605             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3606              
3607 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3608 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3609 0         0 my $qq_string = '';
3610 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3611 0         0 while (not /\G \z/oxgc) {
3612 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3613             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3614 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3615 0         0 elsif (/\G (\)) /oxgc) {
3616             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3617 0         0 else { $qq_string .= $1; }
3618             }
3619 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3620             }
3621             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3622             }
3623              
3624 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3625 2150         2757 elsif (/\G (\{) /oxgc) { # qq { }
3626 2150         2812 my $qq_string = '';
3627 2150 100       4157 local $nest = 1;
  84006 50       250481  
    100          
    100          
    50          
3628 722         1417 while (not /\G \z/oxgc) {
3629 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1662  
3630             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3631 1153 100       2014 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         4958  
3632 2150         4339 elsif (/\G (\}) /oxgc) {
3633             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3634 1153         2243 else { $qq_string .= $1; }
3635             }
3636 78828         167733 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3637             }
3638             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3639             }
3640              
3641 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3642 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3643 0         0 my $qq_string = '';
3644 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3645 0         0 while (not /\G \z/oxgc) {
3646 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3647             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3648 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3649 0         0 elsif (/\G (\]) /oxgc) {
3650             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3651 0         0 else { $qq_string .= $1; }
3652             }
3653 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3654             }
3655             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3656             }
3657              
3658 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3659 30         47 elsif (/\G (\<) /oxgc) { # qq < >
3660 30         41 my $qq_string = '';
3661 30 100       103 local $nest = 1;
  1166 50       4177  
    50          
    100          
    50          
3662 22         53 while (not /\G \z/oxgc) {
3663 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3664             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3665 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         62  
3666 30         65 elsif (/\G (\>) /oxgc) {
3667             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3668 0         0 else { $qq_string .= $1; }
3669             }
3670 1114         2116 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3671             }
3672             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3673             }
3674              
3675 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3676 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3677 0         0 my $delimiter = $1;
3678 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3679 0         0 while (not /\G \z/oxgc) {
3680 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3681 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3682             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3683 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3684             }
3685             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3686 0         0 }
3687             }
3688             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3689             }
3690             }
3691              
3692 0         0 # qr//
3693 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3694 0         0 my $ope = $1;
3695             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3696             return e_qr($ope,$1,$3,$2,$4);
3697 0         0 }
3698 0         0 else {
3699 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3700 0         0 while (not /\G \z/oxgc) {
3701 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3702 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3703 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3704 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3705 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3706 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3707             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3708 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3709             }
3710             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3711             }
3712             }
3713              
3714 0         0 # qw//
3715 16 50       42 elsif (/\G \b (qw) \b /oxgc) {
3716 16         51 my $ope = $1;
3717             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3718             return e_qw($ope,$1,$3,$2);
3719 0         0 }
3720 16         27 else {
3721 16 50       55 my $e = '';
  16 50       113  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3722             while (not /\G \z/oxgc) {
3723 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3724 16         49  
3725             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3726 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3727 0         0  
3728             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3729 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3730 0         0  
3731             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3732 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3733 0         0  
3734             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3735 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3736 0         0  
3737             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3738 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3739             }
3740             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3741             }
3742             }
3743              
3744 0         0 # qx//
3745 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3746 0         0 my $ope = $1;
3747             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3748             return e_qq($ope,$1,$3,$2);
3749 0         0 }
3750 0         0 else {
3751 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3752 0         0 while (not /\G \z/oxgc) {
3753 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3754 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3755 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3756 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3757 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3758             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3759 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3760             }
3761             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3762             }
3763             }
3764              
3765 0         0 # q//
3766             elsif (/\G \b (q) \b /oxgc) {
3767             my $ope = $1;
3768              
3769             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3770              
3771             # avoid "Error: Runtime exception" of perl version 5.005_03
3772 410 50       1090 # (and so on)
3773 410         1026  
3774 0         0 if (/\G (\#) /oxgc) { # q# #
3775 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3776 0         0 while (not /\G \z/oxgc) {
3777 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3778 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3779             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3780 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3781             }
3782             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3783             }
3784 0         0  
3785 410         679 else {
3786 410 50       1159 my $e = '';
  410 50       2089  
    100          
    50          
    100          
    50          
3787             while (not /\G \z/oxgc) {
3788             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3789              
3790 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3791 0         0 elsif (/\G (\() /oxgc) { # q ( )
3792 0         0 my $q_string = '';
3793 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3794 0         0 while (not /\G \z/oxgc) {
3795 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3796 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3797             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3798 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3799 0         0 elsif (/\G (\)) /oxgc) {
3800             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3801 0         0 else { $q_string .= $1; }
3802             }
3803 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3804             }
3805             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3806             }
3807              
3808 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3809 404         673 elsif (/\G (\{) /oxgc) { # q { }
3810 404         640 my $q_string = '';
3811 404 50       1115 local $nest = 1;
  6770 50       25248  
    50          
    100          
    100          
    50          
3812 0         0 while (not /\G \z/oxgc) {
3813 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3814 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         171  
3815             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3816 107 100       177 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         965  
3817 404         1023 elsif (/\G (\}) /oxgc) {
3818             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3819 107         219 else { $q_string .= $1; }
3820             }
3821 6152         11963 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3822             }
3823             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3824             }
3825              
3826 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3827 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3828 0         0 my $q_string = '';
3829 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3830 0         0 while (not /\G \z/oxgc) {
3831 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3832 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3833             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3834 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3835 0         0 elsif (/\G (\]) /oxgc) {
3836             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3837 0         0 else { $q_string .= $1; }
3838             }
3839 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3840             }
3841             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3842             }
3843              
3844 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3845 5         12 elsif (/\G (\<) /oxgc) { # q < >
3846 5         8 my $q_string = '';
3847 5 50       17 local $nest = 1;
  88 50       450  
    50          
    50          
    100          
    50          
3848 0         0 while (not /\G \z/oxgc) {
3849 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3850 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3851             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3852 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         15  
3853 5         15 elsif (/\G (\>) /oxgc) {
3854             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3855 0         0 else { $q_string .= $1; }
3856             }
3857 83         160 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3858             }
3859             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3860             }
3861              
3862 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3863 1         3 elsif (/\G (\S) /oxgc) { # q * *
3864 1         3 my $delimiter = $1;
3865 1 50       5 my $q_string = '';
  14 50       123  
    100          
    50          
3866 0         0 while (not /\G \z/oxgc) {
3867 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3868 1         4 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3869             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3870 13         32 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3871             }
3872             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3873 0         0 }
3874             }
3875             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3876             }
3877             }
3878              
3879 0         0 # m//
3880 209 50       485 elsif (/\G \b (m) \b /oxgc) {
3881 209         1316 my $ope = $1;
3882             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3883             return e_qr($ope,$1,$3,$2,$4);
3884 0         0 }
3885 209         323 else {
3886 209 50       529 my $e = '';
  209 50       10475  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3887 0         0 while (not /\G \z/oxgc) {
3888 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3889 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3890 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3891 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3892 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3893 10         26 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3894 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3895             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3896 199         615 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3897             }
3898             die __FILE__, ": Search pattern not terminated\n";
3899             }
3900             }
3901              
3902             # s///
3903              
3904             # about [cegimosxpradlunbB]* (/cg modifier)
3905             #
3906             # P.67 Pattern-Matching Operators
3907             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3908 0         0  
3909             elsif (/\G \b (s) \b /oxgc) {
3910             my $ope = $1;
3911 97 100       255  
3912 97         1615 # $1 $2 $3 $4 $5 $6
3913             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3914             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3915 1         5 }
3916 96         166 else {
3917 96 50       291 my $e = '';
  96 50       11760  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3918             while (not /\G \z/oxgc) {
3919 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3920 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3921 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3922             while (not /\G \z/oxgc) {
3923 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3924 0         0 # $1 $2 $3 $4
3925 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934             }
3935             die __FILE__, ": Substitution replacement not terminated\n";
3936 0         0 }
3937 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3938 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3939             while (not /\G \z/oxgc) {
3940 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3941 0         0 # $1 $2 $3 $4
3942 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951             }
3952             die __FILE__, ": Substitution replacement not terminated\n";
3953 0         0 }
3954 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3955 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3956             while (not /\G \z/oxgc) {
3957 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3958 0         0 # $1 $2 $3 $4
3959 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966             }
3967             die __FILE__, ": Substitution replacement not terminated\n";
3968 0         0 }
3969 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3970 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3971             while (not /\G \z/oxgc) {
3972 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3973 0         0 # $1 $2 $3 $4
3974 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983             }
3984             die __FILE__, ": Substitution replacement not terminated\n";
3985             }
3986 0         0 # $1 $2 $3 $4 $5 $6
3987             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3988             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3989             }
3990 21         54 # $1 $2 $3 $4 $5 $6
3991             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3992             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3993             }
3994 0         0 # $1 $2 $3 $4 $5 $6
3995             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3996             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3997             }
3998 0         0 # $1 $2 $3 $4 $5 $6
3999             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4000             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4001 75         374 }
4002             }
4003             die __FILE__, ": Substitution pattern not terminated\n";
4004             }
4005             }
4006 0         0  
4007 0         0 # require ignore module
4008 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4009             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4010             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4011 0         0  
4012 37         297 # use strict; --> use strict; no strict qw(refs);
4013 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4014             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4015             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4016              
4017 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4018 2         21 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4019             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4020             return "use $1; no strict qw(refs);";
4021 0         0 }
4022             else {
4023             return "use $1;";
4024             }
4025 2 0 0     11 }
      0        
4026 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4027             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4028             return "use $1; no strict qw(refs);";
4029 0         0 }
4030             else {
4031             return "use $1;";
4032             }
4033             }
4034 0         0  
4035 2         17 # ignore use module
4036 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4037             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4038             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4039 0         0  
4040 0         0 # ignore no module
4041 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4042             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4043             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4044 0         0  
4045             # use else
4046             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4047 0         0  
4048             # use else
4049             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4050              
4051 2         7 # ''
4052 848         1603 elsif (/\G (?
4053 848 100       2045 my $q_string = '';
  8254 100       40634  
    100          
    50          
4054 4         10 while (not /\G \z/oxgc) {
4055 48         85 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4056 848         1773 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4057             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4058 7354         14309 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4059             }
4060             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4061             }
4062              
4063 0         0 # ""
4064 1790         3525 elsif (/\G (\") /oxgc) {
4065 1790 100       4186 my $qq_string = '';
  35119 100       99410  
    100          
    50          
4066 67         155 while (not /\G \z/oxgc) {
4067 12         25 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4068 1790         3856 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4069             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4070 33250         65102 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4071             }
4072             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4073             }
4074              
4075 0         0 # ``
4076 1         3 elsif (/\G (\`) /oxgc) {
4077 1 50       5 my $qx_string = '';
  19 50       68  
    100          
    50          
4078 0         0 while (not /\G \z/oxgc) {
4079 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4080 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4081             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4082 18         35 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4083             }
4084             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4085             }
4086              
4087 0         0 # // --- not divide operator (num / num), not defined-or
4088 453         1410 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4089 453 50       1216 my $regexp = '';
  4496 50       16296  
    100          
    50          
4090 0         0 while (not /\G \z/oxgc) {
4091 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4092 453         1510 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4093             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4094 4043         7841 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4095             }
4096             die __FILE__, ": Search pattern not terminated\n";
4097             }
4098              
4099 0         0 # ?? --- not conditional operator (condition ? then : else)
4100 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4101 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4102 0         0 while (not /\G \z/oxgc) {
4103 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4104 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4105             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4106 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4107             }
4108             die __FILE__, ": Search pattern not terminated\n";
4109             }
4110 0         0  
  0         0  
4111             # <<>> (a safer ARGV)
4112             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4113 0         0  
  0         0  
4114             # << (bit shift) --- not here document
4115             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4116              
4117 0         0 # <<~'HEREDOC'
4118 6         12 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4119 6         11 $slash = 'm//';
4120             my $here_quote = $1;
4121             my $delimiter = $2;
4122 6 50       8  
4123 6         12 # get here document
4124 6         19 if ($here_script eq '') {
4125             $here_script = CORE::substr $_, pos $_;
4126 6 50       29 $here_script =~ s/.*?\n//oxm;
4127 6         63 }
4128 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4129 6         8 my $heredoc = $1;
4130 6         45 my $indent = $2;
4131 6         16 $heredoc =~ s{^$indent}{}msg; # no /ox
4132             push @heredoc, $heredoc . qq{\n$delimiter\n};
4133             push @heredoc_delimiter, qq{\\s*$delimiter};
4134 6         13 }
4135             else {
4136 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4137             }
4138             return qq{<<'$delimiter'};
4139             }
4140              
4141             # <<~\HEREDOC
4142              
4143             # P.66 2.6.6. "Here" Documents
4144             # in Chapter 2: Bits and Pieces
4145             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4146              
4147             # P.73 "Here" Documents
4148             # in Chapter 2: Bits and Pieces
4149             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4150 6         19  
4151 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4152 3         7 $slash = 'm//';
4153             my $here_quote = $1;
4154             my $delimiter = $2;
4155 3 50       5  
4156 3         5 # get here document
4157 3         11 if ($here_script eq '') {
4158             $here_script = CORE::substr $_, pos $_;
4159 3 50       22 $here_script =~ s/.*?\n//oxm;
4160 3         36 }
4161 3         5 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4162 3         6 my $heredoc = $1;
4163 3         33 my $indent = $2;
4164 3         15 $heredoc =~ s{^$indent}{}msg; # no /ox
4165             push @heredoc, $heredoc . qq{\n$delimiter\n};
4166             push @heredoc_delimiter, qq{\\s*$delimiter};
4167 3         6 }
4168             else {
4169 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4170             }
4171             return qq{<<\\$delimiter};
4172             }
4173              
4174 3         12 # <<~"HEREDOC"
4175 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4176 6         15 $slash = 'm//';
4177             my $here_quote = $1;
4178             my $delimiter = $2;
4179 6 50       11  
4180 6         13 # get here document
4181 6         32 if ($here_script eq '') {
4182             $here_script = CORE::substr $_, pos $_;
4183 6 50       35 $here_script =~ s/.*?\n//oxm;
4184 6         70 }
4185 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4186 6         11 my $heredoc = $1;
4187 6         51 my $indent = $2;
4188 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4189             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4190             push @heredoc_delimiter, qq{\\s*$delimiter};
4191 6         17 }
4192             else {
4193 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4194             }
4195             return qq{<<"$delimiter"};
4196             }
4197              
4198 6         27 # <<~HEREDOC
4199 3         12 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4200 3         8 $slash = 'm//';
4201             my $here_quote = $1;
4202             my $delimiter = $2;
4203 3 50       7  
4204 3         10 # get here document
4205 3         15 if ($here_script eq '') {
4206             $here_script = CORE::substr $_, pos $_;
4207 3 50       29 $here_script =~ s/.*?\n//oxm;
4208 3         44 }
4209 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4210 3         7 my $heredoc = $1;
4211 3         94 my $indent = $2;
4212 3         20 $heredoc =~ s{^$indent}{}msg; # no /ox
4213             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4214             push @heredoc_delimiter, qq{\\s*$delimiter};
4215 3         7 }
4216             else {
4217 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4218             }
4219             return qq{<<$delimiter};
4220             }
4221              
4222 3         16 # <<~`HEREDOC`
4223 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4224 6         10 $slash = 'm//';
4225             my $here_quote = $1;
4226             my $delimiter = $2;
4227 6 50       10  
4228 6         13 # get here document
4229 6         15 if ($here_script eq '') {
4230             $here_script = CORE::substr $_, pos $_;
4231 6 50       30 $here_script =~ s/.*?\n//oxm;
4232 6         61 }
4233 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4234 6         8 my $heredoc = $1;
4235 6         55 my $indent = $2;
4236 6         15 $heredoc =~ s{^$indent}{}msg; # no /ox
4237             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4238             push @heredoc_delimiter, qq{\\s*$delimiter};
4239 6         13 }
4240             else {
4241 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4242             }
4243             return qq{<<`$delimiter`};
4244             }
4245              
4246 6         20 # <<'HEREDOC'
4247 72         140 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4248 72         175 $slash = 'm//';
4249             my $here_quote = $1;
4250             my $delimiter = $2;
4251 72 50       117  
4252 72         152 # get here document
4253 72         360 if ($here_script eq '') {
4254             $here_script = CORE::substr $_, pos $_;
4255 72 50       392 $here_script =~ s/.*?\n//oxm;
4256 72         552 }
4257 72         396 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4258             push @heredoc, $1 . qq{\n$delimiter\n};
4259             push @heredoc_delimiter, $delimiter;
4260 72         121 }
4261             else {
4262 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4263             }
4264             return $here_quote;
4265             }
4266              
4267             # <<\HEREDOC
4268              
4269             # P.66 2.6.6. "Here" Documents
4270             # in Chapter 2: Bits and Pieces
4271             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4272              
4273             # P.73 "Here" Documents
4274             # in Chapter 2: Bits and Pieces
4275             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4276 72         273  
4277 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4278 0         0 $slash = 'm//';
4279             my $here_quote = $1;
4280             my $delimiter = $2;
4281 0 0       0  
4282 0         0 # get here document
4283 0         0 if ($here_script eq '') {
4284             $here_script = CORE::substr $_, pos $_;
4285 0 0       0 $here_script =~ s/.*?\n//oxm;
4286 0         0 }
4287 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4288             push @heredoc, $1 . qq{\n$delimiter\n};
4289             push @heredoc_delimiter, $delimiter;
4290 0         0 }
4291             else {
4292 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4293             }
4294             return $here_quote;
4295             }
4296              
4297 0         0 # <<"HEREDOC"
4298 36         166 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4299 36         99 $slash = 'm//';
4300             my $here_quote = $1;
4301             my $delimiter = $2;
4302 36 50       77  
4303 36         94 # get here document
4304 36         290 if ($here_script eq '') {
4305             $here_script = CORE::substr $_, pos $_;
4306 36 50       214 $here_script =~ s/.*?\n//oxm;
4307 36         554 }
4308 36         128 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4309             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4310             push @heredoc_delimiter, $delimiter;
4311 36         82 }
4312             else {
4313 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4314             }
4315             return $here_quote;
4316             }
4317              
4318 36         162 # <
4319 42         111 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4320 42         99 $slash = 'm//';
4321             my $here_quote = $1;
4322             my $delimiter = $2;
4323 42 50       83  
4324 42         112 # get here document
4325 42         284 if ($here_script eq '') {
4326             $here_script = CORE::substr $_, pos $_;
4327 42 50       373 $here_script =~ s/.*?\n//oxm;
4328 42         564 }
4329 42         157 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4330             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4331             push @heredoc_delimiter, $delimiter;
4332 42         112 }
4333             else {
4334 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4335             }
4336             return $here_quote;
4337             }
4338              
4339 42         194 # <<`HEREDOC`
4340 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4341 0         0 $slash = 'm//';
4342             my $here_quote = $1;
4343             my $delimiter = $2;
4344 0 0       0  
4345 0         0 # get here document
4346 0         0 if ($here_script eq '') {
4347             $here_script = CORE::substr $_, pos $_;
4348 0 0       0 $here_script =~ s/.*?\n//oxm;
4349 0         0 }
4350 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4351             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4352             push @heredoc_delimiter, $delimiter;
4353 0         0 }
4354             else {
4355 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4356             }
4357             return $here_quote;
4358             }
4359              
4360 0         0 # <<= <=> <= < operator
4361             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4362             return $1;
4363             }
4364              
4365 12         62 #
4366             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4367             return $1;
4368             }
4369              
4370             # --- glob
4371              
4372             # avoid "Error: Runtime exception" of perl version 5.005_03
4373 0         0  
4374             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4375             return 'Elatin3::glob("' . $1 . '")';
4376             }
4377 0         0  
4378             # __DATA__
4379             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4380 0         0  
4381             # __END__
4382             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4383              
4384             # \cD Control-D
4385              
4386             # P.68 2.6.8. Other Literal Tokens
4387             # in Chapter 2: Bits and Pieces
4388             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4389              
4390             # P.76 Other Literal Tokens
4391             # in Chapter 2: Bits and Pieces
4392 204         1495 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4393              
4394             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4395 0         0  
4396             # \cZ Control-Z
4397             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4398              
4399             # any operator before div
4400             elsif (/\G (
4401             -- | \+\+ |
4402 0         0 [\)\}\]]
  5081         9931  
4403              
4404             ) /oxgc) { $slash = 'div'; return $1; }
4405              
4406             # yada-yada or triple-dot operator
4407             elsif (/\G (
4408 5081         22810 \.\.\.
  7         12  
4409              
4410             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4411              
4412             # any operator before m//
4413              
4414             # //, //= (defined-or)
4415              
4416             # P.164 Logical Operators
4417             # in Chapter 10: More Control Structures
4418             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4419              
4420             # P.119 C-Style Logical (Short-Circuit) Operators
4421             # in Chapter 3: Unary and Binary Operators
4422             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4423              
4424             # (and so on)
4425              
4426             # ~~
4427              
4428             # P.221 The Smart Match Operator
4429             # in Chapter 15: Smart Matching and given-when
4430             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4431              
4432             # P.112 Smartmatch Operator
4433             # in Chapter 3: Unary and Binary Operators
4434             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4435              
4436             # (and so on)
4437              
4438             elsif (/\G ((?>
4439              
4440             !~~ | !~ | != | ! |
4441             %= | % |
4442             &&= | && | &= | &\.= | &\. | & |
4443             -= | -> | - |
4444             :(?>\s*)= |
4445             : |
4446             <<>> |
4447             <<= | <=> | <= | < |
4448             == | => | =~ | = |
4449             >>= | >> | >= | > |
4450             \*\*= | \*\* | \*= | \* |
4451             \+= | \+ |
4452             \.\. | \.= | \. |
4453             \/\/= | \/\/ |
4454             \/= | \/ |
4455             \? |
4456             \\ |
4457             \^= | \^\.= | \^\. | \^ |
4458             \b x= |
4459             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4460             ~~ | ~\. | ~ |
4461             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4462             \b(?: print )\b |
4463              
4464 7         24 [,;\(\{\[]
  8839         16788  
4465              
4466             )) /oxgc) { $slash = 'm//'; return $1; }
4467 8839         38569  
  15137         26784  
4468             # other any character
4469             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4470              
4471 15137         66523 # system error
4472             else {
4473             die __FILE__, ": Oops, this shouldn't happen!\n";
4474             }
4475             }
4476              
4477 0     1786 0 0 # escape Latin-3 string
4478 1786         4064 sub e_string {
4479             my($string) = @_;
4480 1786         2463 my $e_string = '';
4481              
4482             local $slash = 'm//';
4483              
4484             # P.1024 Appendix W.10 Multibyte Processing
4485             # of ISBN 1-56592-224-7 CJKV Information Processing
4486 1786         2533 # (and so on)
4487              
4488             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4489 1786 100 66     20862  
4490 1786 50       7423 # without { ... }
4491 1769         3653 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4492             if ($string !~ /<
4493             return $string;
4494             }
4495             }
4496 1769         4311  
4497 17 50       55 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          
4498             while ($string !~ /\G \z/oxgc) {
4499             if (0) {
4500             }
4501 190         11188  
4502 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin3::PREMATCH()]}
4503 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4504             $e_string .= q{Elatin3::PREMATCH()};
4505             $slash = 'div';
4506             }
4507              
4508 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin3::MATCH()]}
4509 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4510             $e_string .= q{Elatin3::MATCH()};
4511             $slash = 'div';
4512             }
4513              
4514 0         0 # $', ${'} --> $', ${'}
4515 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4516             $e_string .= $1;
4517             $slash = 'div';
4518             }
4519              
4520 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin3::POSTMATCH()]}
4521 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4522             $e_string .= q{Elatin3::POSTMATCH()};
4523             $slash = 'div';
4524             }
4525              
4526 0         0 # bareword
4527 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4528             $e_string .= $1;
4529             $slash = 'div';
4530             }
4531              
4532 0         0 # $0 --> $0
4533 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4534             $e_string .= $1;
4535             $slash = 'div';
4536 0         0 }
4537 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4538             $e_string .= $1;
4539             $slash = 'div';
4540             }
4541              
4542 0         0 # $$ --> $$
4543 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4544             $e_string .= $1;
4545             $slash = 'div';
4546             }
4547              
4548             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4549 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4550 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4551             $e_string .= e_capture($1);
4552             $slash = 'div';
4553 0         0 }
4554 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4555             $e_string .= e_capture($1);
4556             $slash = 'div';
4557             }
4558              
4559 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4560 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4561             $e_string .= e_capture($1.'->'.$2);
4562             $slash = 'div';
4563             }
4564              
4565 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4566 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4567             $e_string .= e_capture($1.'->'.$2);
4568             $slash = 'div';
4569             }
4570              
4571 0         0 # $$foo
4572 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4573             $e_string .= e_capture($1);
4574             $slash = 'div';
4575             }
4576              
4577 0         0 # ${ foo }
4578 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4579             $e_string .= '${' . $1 . '}';
4580             $slash = 'div';
4581             }
4582              
4583 0         0 # ${ ... }
4584 3         9 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4585             $e_string .= e_capture($1);
4586             $slash = 'div';
4587             }
4588              
4589             # variable or function
4590 3         14 # $ @ % & * $ #
4591 7         22 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) {
4592             $e_string .= $1;
4593             $slash = 'div';
4594             }
4595             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4596 7         21 # $ @ # \ ' " / ? ( ) [ ] < >
4597 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4598             $e_string .= $1;
4599             $slash = 'div';
4600             }
4601 0         0  
  0         0  
4602 0         0 # subroutines of package Elatin3
  0         0  
4603 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4604 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4605 0         0 elsif ($string =~ /\G \b Latin3::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4606 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4607 0         0 elsif ($string =~ /\G \b Latin3::eval \b /oxgc) { $e_string .= 'eval Latin3::escape'; $slash = 'm//'; }
  0         0  
4608 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4609 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin3::chop'; $slash = 'm//'; }
  0         0  
4610 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4611 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4612 0         0 elsif ($string =~ /\G \b Latin3::index \b /oxgc) { $e_string .= 'Latin3::index'; $slash = 'm//'; }
  0         0  
4613 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin3::index'; $slash = 'm//'; }
  0         0  
4614 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4615 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4616 0         0 elsif ($string =~ /\G \b Latin3::rindex \b /oxgc) { $e_string .= 'Latin3::rindex'; $slash = 'm//'; }
  0         0  
4617 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin3::rindex'; $slash = 'm//'; }
  0         0  
4618 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin3::lc'; $slash = 'm//'; }
  0         0  
4619 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin3::lcfirst'; $slash = 'm//'; }
  0         0  
4620 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin3::uc'; $slash = 'm//'; }
  0         0  
4621             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin3::ucfirst'; $slash = 'm//'; }
4622             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin3::fc'; $slash = 'm//'; }
4623 0         0  
  0         0  
4624 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4625 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4626 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  
4627 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  
4628 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  
4629 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  
4630             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4631 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  
4632 0         0  
  0         0  
4633 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4634 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  
4635 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  
4636 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  
4637 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  
4638             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4639             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4640 0         0  
  0         0  
4641 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4642 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4643 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4644             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4645 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4646 0         0  
  0         0  
4647 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4648 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4649 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin3::chr'; $slash = 'm//'; }
  0         0  
4650 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4651 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4652 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin3::glob'; $slash = 'm//'; }
  0         0  
4653 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin3::lc_'; $slash = 'm//'; }
  0         0  
4654 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin3::lcfirst_'; $slash = 'm//'; }
  0         0  
4655 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin3::uc_'; $slash = 'm//'; }
  0         0  
4656 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin3::ucfirst_'; $slash = 'm//'; }
  0         0  
4657             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin3::fc_'; $slash = 'm//'; }
4658 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4659 0         0  
  0         0  
4660 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4661 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4662 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin3::chr_'; $slash = 'm//'; }
  0         0  
4663 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4664 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4665 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin3::glob_'; $slash = 'm//'; }
  0         0  
4666             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4667             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4668 0         0 # split
4669             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4670 0         0 $slash = 'm//';
4671 0         0  
4672 0         0 my $e = '';
4673             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4674             $e .= $1;
4675             }
4676 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4677             # end of split
4678             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin3::split' . $e; }
4679 0         0  
  0         0  
4680             # split scalar value
4681             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin3::split' . $e . e_string($1); next E_STRING_LOOP; }
4682 0         0  
  0         0  
4683 0         0 # split literal space
  0         0  
4684 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4685 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4686 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4687 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4688 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4689 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4690 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4691 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4692 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4693 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4694 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4695 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4696             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {' '}; next E_STRING_LOOP; }
4697             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin3::split' . $e . qq {" "}; next E_STRING_LOOP; }
4698              
4699 0 0       0 # split qq//
  0         0  
  0         0  
4700             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4701 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4702 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4703 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4704 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4705 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  
4706 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  
4707 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  
4708 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  
4709             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4710 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 * *
4711             }
4712             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4713             }
4714             }
4715              
4716 0 0       0 # split qr//
  0         0  
  0         0  
4717             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4718 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4719 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4720 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4721 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4722 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  
4723 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  
4724 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  
4725 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  
4726 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  
4727             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4728 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 * *
4729             }
4730             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4731             }
4732             }
4733              
4734 0 0       0 # split q//
  0         0  
  0         0  
4735             elsif ($string =~ /\G \b (q) \b /oxgc) {
4736 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4737 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4738 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4739 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4740 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  
4741 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  
4742 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  
4743 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  
4744             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4745 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 * *
4746             }
4747             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4748             }
4749             }
4750              
4751 0 0       0 # split m//
  0         0  
  0         0  
4752             elsif ($string =~ /\G \b (m) \b /oxgc) {
4753 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 # #
4754 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4755 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4756 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4757 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  
4758 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  
4759 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  
4760 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  
4761 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  
4762             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4763 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 * *
4764             }
4765             die __FILE__, ": Search pattern not terminated\n";
4766             }
4767             }
4768              
4769 0         0 # split ''
4770 0         0 elsif ($string =~ /\G (\') /oxgc) {
4771 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4772 0         0 while ($string !~ /\G \z/oxgc) {
4773 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4774 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4775             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4776 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4777             }
4778             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4779             }
4780              
4781 0         0 # split ""
4782 0         0 elsif ($string =~ /\G (\") /oxgc) {
4783 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4784 0         0 while ($string !~ /\G \z/oxgc) {
4785 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4786 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4787             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4788 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4789             }
4790             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4791             }
4792              
4793 0         0 # split //
4794 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4795 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4796 0         0 while ($string !~ /\G \z/oxgc) {
4797 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4798 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4799             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4800 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4801             }
4802             die __FILE__, ": Search pattern not terminated\n";
4803             }
4804             }
4805              
4806 0         0 # qq//
4807 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4808 0         0 my $ope = $1;
4809             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4810             $e_string .= e_qq($ope,$1,$3,$2);
4811 0         0 }
4812 0         0 else {
4813 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4814 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4815 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4816 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4817 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4818 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4819             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4820 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4821             }
4822             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4823             }
4824             }
4825              
4826 0         0 # qx//
4827 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4828 0         0 my $ope = $1;
4829             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4830             $e_string .= e_qq($ope,$1,$3,$2);
4831 0         0 }
4832 0         0 else {
4833 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4834 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4835 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4836 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4837 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4838 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4839 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4840             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4841 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4842             }
4843             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4844             }
4845             }
4846              
4847 0         0 # q//
4848 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4849 0         0 my $ope = $1;
4850             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4851             $e_string .= e_q($ope,$1,$3,$2);
4852 0         0 }
4853 0         0 else {
4854 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4855 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4856 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4857 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4858 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4859 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4860             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4861 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 * *
4862             }
4863             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4864             }
4865             }
4866 0         0  
4867             # ''
4868             elsif ($string =~ /\G (?
4869 0         0  
4870             # ""
4871             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4872 0         0  
4873             # ``
4874             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4875 0         0  
4876             # <<>> (a safer ARGV)
4877             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4878 0         0  
4879             # <<= <=> <= < operator
4880             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4881 0         0  
4882             #
4883             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4884              
4885 0         0 # --- glob
4886             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4887             $e_string .= 'Elatin3::glob("' . $1 . '")';
4888             }
4889              
4890 0         0 # << (bit shift) --- not here document
4891 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4892             $slash = 'm//';
4893             $e_string .= $1;
4894             }
4895              
4896 0         0 # <<~'HEREDOC'
4897 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4898 0         0 $slash = 'm//';
4899             my $here_quote = $1;
4900             my $delimiter = $2;
4901 0 0       0  
4902 0         0 # get here document
4903 0         0 if ($here_script eq '') {
4904             $here_script = CORE::substr $_, pos $_;
4905 0 0       0 $here_script =~ s/.*?\n//oxm;
4906 0         0 }
4907 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4908 0         0 my $heredoc = $1;
4909 0         0 my $indent = $2;
4910 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4911             push @heredoc, $heredoc . qq{\n$delimiter\n};
4912             push @heredoc_delimiter, qq{\\s*$delimiter};
4913 0         0 }
4914             else {
4915 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4916             }
4917             $e_string .= qq{<<'$delimiter'};
4918             }
4919              
4920 0         0 # <<~\HEREDOC
4921 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4922 0         0 $slash = 'm//';
4923             my $here_quote = $1;
4924             my $delimiter = $2;
4925 0 0       0  
4926 0         0 # get here document
4927 0         0 if ($here_script eq '') {
4928             $here_script = CORE::substr $_, pos $_;
4929 0 0       0 $here_script =~ s/.*?\n//oxm;
4930 0         0 }
4931 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4932 0         0 my $heredoc = $1;
4933 0         0 my $indent = $2;
4934 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4935             push @heredoc, $heredoc . qq{\n$delimiter\n};
4936             push @heredoc_delimiter, qq{\\s*$delimiter};
4937 0         0 }
4938             else {
4939 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4940             }
4941             $e_string .= qq{<<\\$delimiter};
4942             }
4943              
4944 0         0 # <<~"HEREDOC"
4945 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4946 0         0 $slash = 'm//';
4947             my $here_quote = $1;
4948             my $delimiter = $2;
4949 0 0       0  
4950 0         0 # get here document
4951 0         0 if ($here_script eq '') {
4952             $here_script = CORE::substr $_, pos $_;
4953 0 0       0 $here_script =~ s/.*?\n//oxm;
4954 0         0 }
4955 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4956 0         0 my $heredoc = $1;
4957 0         0 my $indent = $2;
4958 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4959             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4960             push @heredoc_delimiter, qq{\\s*$delimiter};
4961 0         0 }
4962             else {
4963 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4964             }
4965             $e_string .= qq{<<"$delimiter"};
4966             }
4967              
4968 0         0 # <<~HEREDOC
4969 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4970 0         0 $slash = 'm//';
4971             my $here_quote = $1;
4972             my $delimiter = $2;
4973 0 0       0  
4974 0         0 # get here document
4975 0         0 if ($here_script eq '') {
4976             $here_script = CORE::substr $_, pos $_;
4977 0 0       0 $here_script =~ s/.*?\n//oxm;
4978 0         0 }
4979 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4980 0         0 my $heredoc = $1;
4981 0         0 my $indent = $2;
4982 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4983             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4984             push @heredoc_delimiter, qq{\\s*$delimiter};
4985 0         0 }
4986             else {
4987 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4988             }
4989             $e_string .= qq{<<$delimiter};
4990             }
4991              
4992 0         0 # <<~`HEREDOC`
4993 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4994 0         0 $slash = 'm//';
4995             my $here_quote = $1;
4996             my $delimiter = $2;
4997 0 0       0  
4998 0         0 # get here document
4999 0         0 if ($here_script eq '') {
5000             $here_script = CORE::substr $_, pos $_;
5001 0 0       0 $here_script =~ s/.*?\n//oxm;
5002 0         0 }
5003 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5004 0         0 my $heredoc = $1;
5005 0         0 my $indent = $2;
5006 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5007             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5008             push @heredoc_delimiter, qq{\\s*$delimiter};
5009 0         0 }
5010             else {
5011 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5012             }
5013             $e_string .= qq{<<`$delimiter`};
5014             }
5015              
5016 0         0 # <<'HEREDOC'
5017 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5018 0         0 $slash = 'm//';
5019             my $here_quote = $1;
5020             my $delimiter = $2;
5021 0 0       0  
5022 0         0 # get here document
5023 0         0 if ($here_script eq '') {
5024             $here_script = CORE::substr $_, pos $_;
5025 0 0       0 $here_script =~ s/.*?\n//oxm;
5026 0         0 }
5027 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5028             push @heredoc, $1 . qq{\n$delimiter\n};
5029             push @heredoc_delimiter, $delimiter;
5030 0         0 }
5031             else {
5032 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5033             }
5034             $e_string .= $here_quote;
5035             }
5036              
5037 0         0 # <<\HEREDOC
5038 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5039 0         0 $slash = 'm//';
5040             my $here_quote = $1;
5041             my $delimiter = $2;
5042 0 0       0  
5043 0         0 # get here document
5044 0         0 if ($here_script eq '') {
5045             $here_script = CORE::substr $_, pos $_;
5046 0 0       0 $here_script =~ s/.*?\n//oxm;
5047 0         0 }
5048 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5049             push @heredoc, $1 . qq{\n$delimiter\n};
5050             push @heredoc_delimiter, $delimiter;
5051 0         0 }
5052             else {
5053 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5054             }
5055             $e_string .= $here_quote;
5056             }
5057              
5058 0         0 # <<"HEREDOC"
5059 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5060 0         0 $slash = 'm//';
5061             my $here_quote = $1;
5062             my $delimiter = $2;
5063 0 0       0  
5064 0         0 # get here document
5065 0         0 if ($here_script eq '') {
5066             $here_script = CORE::substr $_, pos $_;
5067 0 0       0 $here_script =~ s/.*?\n//oxm;
5068 0         0 }
5069 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5070             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5071             push @heredoc_delimiter, $delimiter;
5072 0         0 }
5073             else {
5074 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5075             }
5076             $e_string .= $here_quote;
5077             }
5078              
5079 0         0 # <
5080 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5081 0         0 $slash = 'm//';
5082             my $here_quote = $1;
5083             my $delimiter = $2;
5084 0 0       0  
5085 0         0 # get here document
5086 0         0 if ($here_script eq '') {
5087             $here_script = CORE::substr $_, pos $_;
5088 0 0       0 $here_script =~ s/.*?\n//oxm;
5089 0         0 }
5090 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5091             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5092             push @heredoc_delimiter, $delimiter;
5093 0         0 }
5094             else {
5095 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5096             }
5097             $e_string .= $here_quote;
5098             }
5099              
5100 0         0 # <<`HEREDOC`
5101 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5102 0         0 $slash = 'm//';
5103             my $here_quote = $1;
5104             my $delimiter = $2;
5105 0 0       0  
5106 0         0 # get here document
5107 0         0 if ($here_script eq '') {
5108             $here_script = CORE::substr $_, pos $_;
5109 0 0       0 $here_script =~ s/.*?\n//oxm;
5110 0         0 }
5111 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5112             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5113             push @heredoc_delimiter, $delimiter;
5114 0         0 }
5115             else {
5116 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5117             }
5118             $e_string .= $here_quote;
5119             }
5120              
5121             # any operator before div
5122             elsif ($string =~ /\G (
5123             -- | \+\+ |
5124 0         0 [\)\}\]]
  18         33  
5125              
5126             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5127              
5128             # yada-yada or triple-dot operator
5129             elsif ($string =~ /\G (
5130 18         49 \.\.\.
  0         0  
5131              
5132             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5133              
5134             # any operator before m//
5135             elsif ($string =~ /\G ((?>
5136              
5137             !~~ | !~ | != | ! |
5138             %= | % |
5139             &&= | && | &= | &\.= | &\. | & |
5140             -= | -> | - |
5141             :(?>\s*)= |
5142             : |
5143             <<>> |
5144             <<= | <=> | <= | < |
5145             == | => | =~ | = |
5146             >>= | >> | >= | > |
5147             \*\*= | \*\* | \*= | \* |
5148             \+= | \+ |
5149             \.\. | \.= | \. |
5150             \/\/= | \/\/ |
5151             \/= | \/ |
5152             \? |
5153             \\ |
5154             \^= | \^\.= | \^\. | \^ |
5155             \b x= |
5156             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5157             ~~ | ~\. | ~ |
5158             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5159             \b(?: print )\b |
5160              
5161 0         0 [,;\(\{\[]
  31         59  
5162              
5163             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5164 31         104  
5165             # other any character
5166             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5167              
5168 131         350 # system error
5169             else {
5170             die __FILE__, ": Oops, this shouldn't happen!\n";
5171             }
5172 0         0 }
5173              
5174             return $e_string;
5175             }
5176              
5177             #
5178             # character class
5179 17     1919 0 70 #
5180             sub character_class {
5181 1919 100       3275 my($char,$modifier) = @_;
5182 1919 100       2887  
5183 52         97 if ($char eq '.') {
5184             if ($modifier =~ /s/) {
5185             return '${Elatin3::dot_s}';
5186 17         37 }
5187             else {
5188             return '${Elatin3::dot}';
5189             }
5190 35         71 }
5191             else {
5192             return Elatin3::classic_character_class($char);
5193             }
5194             }
5195              
5196             #
5197             # escape capture ($1, $2, $3, ...)
5198             #
5199 1867     212 0 3091 sub e_capture {
5200              
5201             return join '', '${', $_[0], '}';
5202             }
5203              
5204             #
5205             # escape transliteration (tr/// or y///)
5206 212     3 0 741 #
5207 3         22 sub e_tr {
5208 3   50     5 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5209             my $e_tr = '';
5210 3         10 $modifier ||= '';
5211              
5212             $slash = 'div';
5213 3         5  
5214             # quote character class 1
5215             $charclass = q_tr($charclass);
5216 3         9  
5217             # quote character class 2
5218             $charclass2 = q_tr($charclass2);
5219 3 50       6  
5220 3 0       19 # /b /B modifier
5221 0         0 if ($modifier =~ tr/bB//d) {
5222             if ($variable eq '') {
5223             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5224 0         0 }
5225             else {
5226             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5227             }
5228 0 100       0 }
5229 3         9 else {
5230             if ($variable eq '') {
5231             $e_tr = qq{Elatin3::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5232 2         10 }
5233             else {
5234             $e_tr = qq{Elatin3::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5235             }
5236             }
5237 1         4  
5238 3         6 # clear tr/// variable
5239             $tr_variable = '';
5240 3         5 $bind_operator = '';
5241              
5242             return $e_tr;
5243             }
5244              
5245             #
5246             # quote for escape transliteration (tr/// or y///)
5247 3     6 0 16 #
5248             sub q_tr {
5249             my($charclass) = @_;
5250 6 50       11  
    0          
    0          
    0          
    0          
    0          
5251 6         13 # quote character class
5252             if ($charclass !~ /'/oxms) {
5253             return e_q('', "'", "'", $charclass); # --> q' '
5254 6         13 }
5255             elsif ($charclass !~ /\//oxms) {
5256             return e_q('q', '/', '/', $charclass); # --> q/ /
5257 0         0 }
5258             elsif ($charclass !~ /\#/oxms) {
5259             return e_q('q', '#', '#', $charclass); # --> q# #
5260 0         0 }
5261             elsif ($charclass !~ /[\<\>]/oxms) {
5262             return e_q('q', '<', '>', $charclass); # --> q< >
5263 0         0 }
5264             elsif ($charclass !~ /[\(\)]/oxms) {
5265             return e_q('q', '(', ')', $charclass); # --> q( )
5266 0         0 }
5267             elsif ($charclass !~ /[\{\}]/oxms) {
5268             return e_q('q', '{', '}', $charclass); # --> q{ }
5269 0         0 }
5270 0 0       0 else {
5271 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5272             if ($charclass !~ /\Q$char\E/xms) {
5273             return e_q('q', $char, $char, $charclass);
5274             }
5275             }
5276 0         0 }
5277              
5278             return e_q('q', '{', '}', $charclass);
5279             }
5280              
5281             #
5282             # escape q string (q//, '')
5283 0     1264 0 0 #
5284             sub e_q {
5285 1264         2841 my($ope,$delimiter,$end_delimiter,$string) = @_;
5286              
5287 1264         1638 $slash = 'div';
5288              
5289             return join '', $ope, $delimiter, $string, $end_delimiter;
5290             }
5291              
5292             #
5293             # escape qq string (qq//, "", qx//, ``)
5294 1264     4052 0 6038 #
5295             sub e_qq {
5296 4052         8625 my($ope,$delimiter,$end_delimiter,$string) = @_;
5297              
5298 4052         5217 $slash = 'div';
5299 4052         4815  
5300             my $left_e = 0;
5301             my $right_e = 0;
5302 4052         4349  
5303             # split regexp
5304             my @char = $string =~ /\G((?>
5305             [^\\\$] |
5306             \\x\{ (?>[0-9A-Fa-f]+) \} |
5307             \\o\{ (?>[0-7]+) \} |
5308             \\N\{ (?>[^0-9\}][^\}]*) \} |
5309             \\ $q_char |
5310             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5311             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5312             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5313             \$ (?>\s* [0-9]+) |
5314             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5315             \$ \$ (?![\w\{]) |
5316             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5317             $q_char
5318 4052         133738 ))/oxmsg;
5319              
5320             for (my $i=0; $i <= $#char; $i++) {
5321 4052 50 33     12595  
    50 33        
    100          
    100          
    50          
5322 113799         354052 # "\L\u" --> "\u\L"
5323             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5324             @char[$i,$i+1] = @char[$i+1,$i];
5325             }
5326              
5327 0         0 # "\U\l" --> "\l\U"
5328             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5329             @char[$i,$i+1] = @char[$i+1,$i];
5330             }
5331              
5332 0         0 # octal escape sequence
5333             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5334             $char[$i] = Elatin3::octchr($1);
5335             }
5336              
5337 1         5 # hexadecimal escape sequence
5338             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5339             $char[$i] = Elatin3::hexchr($1);
5340             }
5341              
5342 1         4 # \N{CHARNAME} --> N{CHARNAME}
5343             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5344             $char[$i] = $1;
5345 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          
5346              
5347             if (0) {
5348             }
5349              
5350             # \F
5351             #
5352             # P.69 Table 2-6. Translation escapes
5353             # in Chapter 2: Bits and Pieces
5354             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5355             # (and so on)
5356 113799         947013  
5357 0 50       0 # \u \l \U \L \F \Q \E
5358 484         1021 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5359             if ($right_e < $left_e) {
5360             $char[$i] = '\\' . $char[$i];
5361             }
5362             }
5363             elsif ($char[$i] eq '\u') {
5364              
5365             # "STRING @{[ LIST EXPR ]} MORE STRING"
5366              
5367             # P.257 Other Tricks You Can Do with Hard References
5368             # in Chapter 8: References
5369             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5370              
5371             # P.353 Other Tricks You Can Do with Hard References
5372             # in Chapter 8: References
5373             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5374              
5375 0         0 # (and so on)
5376 0         0  
5377             $char[$i] = '@{[Elatin3::ucfirst qq<';
5378             $left_e++;
5379 0         0 }
5380 0         0 elsif ($char[$i] eq '\l') {
5381             $char[$i] = '@{[Elatin3::lcfirst qq<';
5382             $left_e++;
5383 0         0 }
5384 0         0 elsif ($char[$i] eq '\U') {
5385             $char[$i] = '@{[Elatin3::uc qq<';
5386             $left_e++;
5387 0         0 }
5388 0         0 elsif ($char[$i] eq '\L') {
5389             $char[$i] = '@{[Elatin3::lc qq<';
5390             $left_e++;
5391 0         0 }
5392 24         29 elsif ($char[$i] eq '\F') {
5393             $char[$i] = '@{[Elatin3::fc qq<';
5394             $left_e++;
5395 24         47 }
5396 0         0 elsif ($char[$i] eq '\Q') {
5397             $char[$i] = '@{[CORE::quotemeta qq<';
5398             $left_e++;
5399 0 50       0 }
5400 24         46 elsif ($char[$i] eq '\E') {
5401 24         31 if ($right_e < $left_e) {
5402             $char[$i] = '>]}';
5403             $right_e++;
5404 24         44 }
5405             else {
5406             $char[$i] = '';
5407             }
5408 0         0 }
5409 0 0       0 elsif ($char[$i] eq '\Q') {
5410 0         0 while (1) {
5411             if (++$i > $#char) {
5412 0 0       0 last;
5413 0         0 }
5414             if ($char[$i] eq '\E') {
5415             last;
5416             }
5417             }
5418             }
5419             elsif ($char[$i] eq '\E') {
5420             }
5421              
5422             # $0 --> $0
5423             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5424             }
5425             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5426             }
5427              
5428             # $$ --> $$
5429             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5430             }
5431              
5432             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5433 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5434             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5435             $char[$i] = e_capture($1);
5436 205         363 }
5437             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5438             $char[$i] = e_capture($1);
5439             }
5440              
5441 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5442             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5443             $char[$i] = e_capture($1.'->'.$2);
5444             }
5445              
5446 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5447             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5448             $char[$i] = e_capture($1.'->'.$2);
5449             }
5450              
5451 0         0 # $$foo
5452             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5453             $char[$i] = e_capture($1);
5454             }
5455              
5456 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin3::PREMATCH()
5457             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5458             $char[$i] = '@{[Elatin3::PREMATCH()]}';
5459             }
5460              
5461 44         113 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin3::MATCH()
5462             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5463             $char[$i] = '@{[Elatin3::MATCH()]}';
5464             }
5465              
5466 45         117 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin3::POSTMATCH()
5467             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5468             $char[$i] = '@{[Elatin3::POSTMATCH()]}';
5469             }
5470              
5471             # ${ foo } --> ${ foo }
5472             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5473             }
5474              
5475 33         81 # ${ ... }
5476             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5477             $char[$i] = e_capture($1);
5478             }
5479             }
5480 0 50       0  
5481 4052         7576 # return string
5482             if ($left_e > $right_e) {
5483 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5484             }
5485             return join '', $ope, $delimiter, @char, $end_delimiter;
5486             }
5487              
5488             #
5489             # escape qw string (qw//)
5490 4052     16 0 32425 #
5491             sub e_qw {
5492 16         68 my($ope,$delimiter,$end_delimiter,$string) = @_;
5493              
5494             $slash = 'div';
5495 16         37  
  16         191  
5496 483 50       738 # choice again delimiter
    0          
    0          
    0          
    0          
5497 16         111 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5498             if (not $octet{$end_delimiter}) {
5499             return join '', $ope, $delimiter, $string, $end_delimiter;
5500 16         120 }
5501             elsif (not $octet{')'}) {
5502             return join '', $ope, '(', $string, ')';
5503 0         0 }
5504             elsif (not $octet{'}'}) {
5505             return join '', $ope, '{', $string, '}';
5506 0         0 }
5507             elsif (not $octet{']'}) {
5508             return join '', $ope, '[', $string, ']';
5509 0         0 }
5510             elsif (not $octet{'>'}) {
5511             return join '', $ope, '<', $string, '>';
5512 0         0 }
5513 0 0       0 else {
5514 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5515             if (not $octet{$char}) {
5516             return join '', $ope, $char, $string, $char;
5517             }
5518             }
5519             }
5520 0         0  
5521 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5522 0         0 my @string = CORE::split(/\s+/, $string);
5523 0         0 for my $string (@string) {
5524 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5525 0         0 for my $octet (@octet) {
5526             if ($octet =~ /\A (['\\]) \z/oxms) {
5527             $octet = '\\' . $1;
5528 0         0 }
5529             }
5530 0         0 $string = join '', @octet;
  0         0  
5531             }
5532             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5533             }
5534              
5535             #
5536             # escape here document (<<"HEREDOC", <
5537 0     93 0 0 #
5538             sub e_heredoc {
5539 93         259 my($string) = @_;
5540              
5541 93         157 $slash = 'm//';
5542              
5543 93         384 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5544 93         715  
5545             my $left_e = 0;
5546             my $right_e = 0;
5547 93         123  
5548             # split regexp
5549             my @char = $string =~ /\G((?>
5550             [^\\\$] |
5551             \\x\{ (?>[0-9A-Fa-f]+) \} |
5552             \\o\{ (?>[0-7]+) \} |
5553             \\N\{ (?>[^0-9\}][^\}]*) \} |
5554             \\ $q_char |
5555             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5556             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5557             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5558             \$ (?>\s* [0-9]+) |
5559             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5560             \$ \$ (?![\w\{]) |
5561             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5562             $q_char
5563 93         9609 ))/oxmsg;
5564              
5565             for (my $i=0; $i <= $#char; $i++) {
5566 93 50 33     434  
    50 33        
    100          
    100          
    50          
5567 3177         12436 # "\L\u" --> "\u\L"
5568             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5569             @char[$i,$i+1] = @char[$i+1,$i];
5570             }
5571              
5572 0         0 # "\U\l" --> "\l\U"
5573             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5574             @char[$i,$i+1] = @char[$i+1,$i];
5575             }
5576              
5577 0         0 # octal escape sequence
5578             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5579             $char[$i] = Elatin3::octchr($1);
5580             }
5581              
5582 1         5 # hexadecimal escape sequence
5583             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5584             $char[$i] = Elatin3::hexchr($1);
5585             }
5586              
5587 1         3 # \N{CHARNAME} --> N{CHARNAME}
5588             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5589             $char[$i] = $1;
5590 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          
5591              
5592             if (0) {
5593             }
5594 3177         30252  
5595 0 0       0 # \u \l \U \L \F \Q \E
5596 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5597             if ($right_e < $left_e) {
5598             $char[$i] = '\\' . $char[$i];
5599             }
5600 0         0 }
5601 0         0 elsif ($char[$i] eq '\u') {
5602             $char[$i] = '@{[Elatin3::ucfirst qq<';
5603             $left_e++;
5604 0         0 }
5605 0         0 elsif ($char[$i] eq '\l') {
5606             $char[$i] = '@{[Elatin3::lcfirst qq<';
5607             $left_e++;
5608 0         0 }
5609 0         0 elsif ($char[$i] eq '\U') {
5610             $char[$i] = '@{[Elatin3::uc qq<';
5611             $left_e++;
5612 0         0 }
5613 0         0 elsif ($char[$i] eq '\L') {
5614             $char[$i] = '@{[Elatin3::lc qq<';
5615             $left_e++;
5616 0         0 }
5617 0         0 elsif ($char[$i] eq '\F') {
5618             $char[$i] = '@{[Elatin3::fc qq<';
5619             $left_e++;
5620 0         0 }
5621 0         0 elsif ($char[$i] eq '\Q') {
5622             $char[$i] = '@{[CORE::quotemeta qq<';
5623             $left_e++;
5624 0 0       0 }
5625 0         0 elsif ($char[$i] eq '\E') {
5626 0         0 if ($right_e < $left_e) {
5627             $char[$i] = '>]}';
5628             $right_e++;
5629 0         0 }
5630             else {
5631             $char[$i] = '';
5632             }
5633 0         0 }
5634 0 0       0 elsif ($char[$i] eq '\Q') {
5635 0         0 while (1) {
5636             if (++$i > $#char) {
5637 0 0       0 last;
5638 0         0 }
5639             if ($char[$i] eq '\E') {
5640             last;
5641             }
5642             }
5643             }
5644             elsif ($char[$i] eq '\E') {
5645             }
5646              
5647             # $0 --> $0
5648             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5649             }
5650             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5651             }
5652              
5653             # $$ --> $$
5654             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5655             }
5656              
5657             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5658 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5659             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5660             $char[$i] = e_capture($1);
5661 0         0 }
5662             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5663             $char[$i] = e_capture($1);
5664             }
5665              
5666 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5667             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5668             $char[$i] = e_capture($1.'->'.$2);
5669             }
5670              
5671 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5672             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5673             $char[$i] = e_capture($1.'->'.$2);
5674             }
5675              
5676 0         0 # $$foo
5677             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5678             $char[$i] = e_capture($1);
5679             }
5680              
5681 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin3::PREMATCH()
5682             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5683             $char[$i] = '@{[Elatin3::PREMATCH()]}';
5684             }
5685              
5686 8         48 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin3::MATCH()
5687             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5688             $char[$i] = '@{[Elatin3::MATCH()]}';
5689             }
5690              
5691 8         43 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin3::POSTMATCH()
5692             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5693             $char[$i] = '@{[Elatin3::POSTMATCH()]}';
5694             }
5695              
5696             # ${ foo } --> ${ foo }
5697             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5698             }
5699              
5700 6         38 # ${ ... }
5701             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5702             $char[$i] = e_capture($1);
5703             }
5704             }
5705 0 50       0  
5706 93         253 # return string
5707             if ($left_e > $right_e) {
5708 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5709             }
5710             return join '', @char;
5711             }
5712              
5713             #
5714             # escape regexp (m//, qr//)
5715 93     652 0 2365 #
5716 652   100     2904 sub e_qr {
5717             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5718 652         2588 $modifier ||= '';
5719 652 50       1056  
5720 652         1434 $modifier =~ tr/p//d;
5721 0         0 if ($modifier =~ /([adlu])/oxms) {
5722 0 0       0 my $line = 0;
5723 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5724 0         0 if ($filename ne __FILE__) {
5725             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5726             last;
5727 0         0 }
5728             }
5729             die qq{Unsupported modifier "$1" used at line $line.\n};
5730 0         0 }
5731              
5732             $slash = 'div';
5733 652 100       1026  
    100          
5734 652         1859 # literal null string pattern
5735 8         9 if ($string eq '') {
5736 8         60 $modifier =~ tr/bB//d;
5737             $modifier =~ tr/i//d;
5738             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5739             }
5740              
5741             # /b /B modifier
5742             elsif ($modifier =~ tr/bB//d) {
5743 8 50       41  
5744 2         7 # choice again delimiter
5745 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5746 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5747 0         0 my %octet = map {$_ => 1} @char;
5748 0         0 if (not $octet{')'}) {
5749             $delimiter = '(';
5750             $end_delimiter = ')';
5751 0         0 }
5752 0         0 elsif (not $octet{'}'}) {
5753             $delimiter = '{';
5754             $end_delimiter = '}';
5755 0         0 }
5756 0         0 elsif (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       0 else {
5765 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5766 0         0 if (not $octet{$char}) {
5767 0         0 $delimiter = $char;
5768             $end_delimiter = $char;
5769             last;
5770             }
5771             }
5772             }
5773 0 50 33     0 }
5774 2         11  
5775             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5776             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5777 0         0 }
5778             else {
5779             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5780             }
5781 2 100       11 }
5782 642         1345  
5783             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5784             my $metachar = qr/[\@\\|[\]{^]/oxms;
5785 642         2564  
5786             # split regexp
5787             my @char = $string =~ /\G((?>
5788             [^\\\$\@\[\(] |
5789             \\x (?>[0-9A-Fa-f]{1,2}) |
5790             \\ (?>[0-7]{2,3}) |
5791             \\c [\x40-\x5F] |
5792             \\x\{ (?>[0-9A-Fa-f]+) \} |
5793             \\o\{ (?>[0-7]+) \} |
5794             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5795             \\ $q_char |
5796             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5797             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5798             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5799             [\$\@] $qq_variable |
5800             \$ (?>\s* [0-9]+) |
5801             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5802             \$ \$ (?![\w\{]) |
5803             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5804             \[\^ |
5805             \[\: (?>[a-z]+) :\] |
5806             \[\:\^ (?>[a-z]+) :\] |
5807             \(\? |
5808             $q_char
5809             ))/oxmsg;
5810 642 50       77522  
5811 642         2596 # choice again delimiter
  0         0  
5812 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5813 0         0 my %octet = map {$_ => 1} @char;
5814 0         0 if (not $octet{')'}) {
5815             $delimiter = '(';
5816             $end_delimiter = ')';
5817 0         0 }
5818 0         0 elsif (not $octet{'}'}) {
5819             $delimiter = '{';
5820             $end_delimiter = '}';
5821 0         0 }
5822 0         0 elsif (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       0 else {
5831 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5832 0         0 if (not $octet{$char}) {
5833 0         0 $delimiter = $char;
5834             $end_delimiter = $char;
5835             last;
5836             }
5837             }
5838             }
5839 0         0 }
5840 642         925  
5841 642         828 my $left_e = 0;
5842             my $right_e = 0;
5843             for (my $i=0; $i <= $#char; $i++) {
5844 642 50 66     1513  
    50 66        
    100          
    100          
    100          
    100          
5845 1872         10603 # "\L\u" --> "\u\L"
5846             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5847             @char[$i,$i+1] = @char[$i+1,$i];
5848             }
5849              
5850 0         0 # "\U\l" --> "\l\U"
5851             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5852             @char[$i,$i+1] = @char[$i+1,$i];
5853             }
5854              
5855 0         0 # octal escape sequence
5856             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5857             $char[$i] = Elatin3::octchr($1);
5858             }
5859              
5860 1         5 # hexadecimal escape sequence
5861             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5862             $char[$i] = Elatin3::hexchr($1);
5863             }
5864              
5865             # \b{...} --> b\{...}
5866             # \B{...} --> B\{...}
5867             # \N{CHARNAME} --> N\{CHARNAME}
5868             # \p{PROPERTY} --> p\{PROPERTY}
5869 1         57 # \P{PROPERTY} --> P\{PROPERTY}
5870             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5871             $char[$i] = $1 . '\\' . $2;
5872             }
5873              
5874 6         18 # \p, \P, \X --> p, P, X
5875             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5876             $char[$i] = $1;
5877 4 100 100     10 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5878              
5879             if (0) {
5880             }
5881 1872         20165  
5882 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5883 6         83 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5884             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)) {
5885             $char[$i] .= join '', splice @char, $i+1, 3;
5886 0         0 }
5887             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)) {
5888             $char[$i] .= join '', splice @char, $i+1, 2;
5889 0         0 }
5890             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)) {
5891             $char[$i] .= join '', splice @char, $i+1, 1;
5892             }
5893             }
5894              
5895 0         0 # open character class [...]
5896             elsif ($char[$i] eq '[') {
5897             my $left = $i;
5898              
5899             # [] make die "Unmatched [] in regexp ...\n"
5900 328 100       446 # (and so on)
5901 328         707  
5902             if ($char[$i+1] eq ']') {
5903             $i++;
5904 3         5 }
5905 328 50       388  
5906 1379         1999 while (1) {
5907             if (++$i > $#char) {
5908 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5909 1379         2128 }
5910             if ($char[$i] eq ']') {
5911             my $right = $i;
5912 328 100       455  
5913 328         1599 # [...]
  30         65  
5914             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5915             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin3::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5916 90         144 }
5917             else {
5918             splice @char, $left, $right-$left+1, Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
5919 298         1115 }
5920 328         579  
5921             $i = $left;
5922             last;
5923             }
5924             }
5925             }
5926              
5927 328         806 # open character class [^...]
5928             elsif ($char[$i] eq '[^') {
5929             my $left = $i;
5930              
5931             # [^] make die "Unmatched [] in regexp ...\n"
5932 74 100       97 # (and so on)
5933 74         147  
5934             if ($char[$i+1] eq ']') {
5935             $i++;
5936 4         5 }
5937 74 50       90  
5938 272         372 while (1) {
5939             if (++$i > $#char) {
5940 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5941 272         417 }
5942             if ($char[$i] eq ']') {
5943             my $right = $i;
5944 74 100       85  
5945 74         318 # [^...]
  30         68  
5946             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5947             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin3::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5948 90         145 }
5949             else {
5950             splice @char, $left, $right-$left+1, Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5951 44         162 }
5952 74         130  
5953             $i = $left;
5954             last;
5955             }
5956             }
5957             }
5958              
5959 74         176 # rewrite character class or escape character
5960             elsif (my $char = character_class($char[$i],$modifier)) {
5961             $char[$i] = $char;
5962             }
5963              
5964 139 50       333 # /i modifier
5965 20         36 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin3::uc($char[$i]) ne Elatin3::fc($char[$i]))) {
5966             if (CORE::length(Elatin3::fc($char[$i])) == 1) {
5967             $char[$i] = '[' . Elatin3::uc($char[$i]) . Elatin3::fc($char[$i]) . ']';
5968 20         33 }
5969             else {
5970             $char[$i] = '(?:' . Elatin3::uc($char[$i]) . '|' . Elatin3::fc($char[$i]) . ')';
5971             }
5972             }
5973              
5974 0 50       0 # \u \l \U \L \F \Q \E
5975 1         4 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5976             if ($right_e < $left_e) {
5977             $char[$i] = '\\' . $char[$i];
5978             }
5979 0         0 }
5980 0         0 elsif ($char[$i] eq '\u') {
5981             $char[$i] = '@{[Elatin3::ucfirst qq<';
5982             $left_e++;
5983 0         0 }
5984 0         0 elsif ($char[$i] eq '\l') {
5985             $char[$i] = '@{[Elatin3::lcfirst qq<';
5986             $left_e++;
5987 0         0 }
5988 1         2 elsif ($char[$i] eq '\U') {
5989             $char[$i] = '@{[Elatin3::uc qq<';
5990             $left_e++;
5991 1         4 }
5992 1         2 elsif ($char[$i] eq '\L') {
5993             $char[$i] = '@{[Elatin3::lc qq<';
5994             $left_e++;
5995 1         4 }
5996 18         35 elsif ($char[$i] eq '\F') {
5997             $char[$i] = '@{[Elatin3::fc qq<';
5998             $left_e++;
5999 18         39 }
6000 1         3 elsif ($char[$i] eq '\Q') {
6001             $char[$i] = '@{[CORE::quotemeta qq<';
6002             $left_e++;
6003 1 50       3 }
6004 21         45 elsif ($char[$i] eq '\E') {
6005 21         26 if ($right_e < $left_e) {
6006             $char[$i] = '>]}';
6007             $right_e++;
6008 21         44 }
6009             else {
6010             $char[$i] = '';
6011             }
6012 0         0 }
6013 0 0       0 elsif ($char[$i] eq '\Q') {
6014 0         0 while (1) {
6015             if (++$i > $#char) {
6016 0 0       0 last;
6017 0         0 }
6018             if ($char[$i] eq '\E') {
6019             last;
6020             }
6021             }
6022             }
6023             elsif ($char[$i] eq '\E') {
6024             }
6025              
6026 0 0       0 # $0 --> $0
6027 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6028             if ($ignorecase) {
6029             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6030             }
6031 0 0       0 }
6032 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6033             if ($ignorecase) {
6034             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6035             }
6036             }
6037              
6038             # $$ --> $$
6039             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6040             }
6041              
6042             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6043 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6044 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6045 0         0 $char[$i] = e_capture($1);
6046             if ($ignorecase) {
6047             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6048             }
6049 0         0 }
6050 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6051 0         0 $char[$i] = e_capture($1);
6052             if ($ignorecase) {
6053             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6054             }
6055             }
6056              
6057 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6058 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) {
6059 0         0 $char[$i] = e_capture($1.'->'.$2);
6060             if ($ignorecase) {
6061             $char[$i] = '@{[Elatin3::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_brace)*? \} ) \z/oxms) {
6067 0         0 $char[$i] = e_capture($1.'->'.$2);
6068             if ($ignorecase) {
6069             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6070             }
6071             }
6072              
6073 0         0 # $$foo
6074 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6075 0         0 $char[$i] = e_capture($1);
6076             if ($ignorecase) {
6077             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6078             }
6079             }
6080              
6081 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin3::PREMATCH()
6082 8         19 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6083             if ($ignorecase) {
6084             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::PREMATCH())]}';
6085 0         0 }
6086             else {
6087             $char[$i] = '@{[Elatin3::PREMATCH()]}';
6088             }
6089             }
6090              
6091 8 50       24 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin3::MATCH()
6092 8         20 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6093             if ($ignorecase) {
6094             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::MATCH())]}';
6095 0         0 }
6096             else {
6097             $char[$i] = '@{[Elatin3::MATCH()]}';
6098             }
6099             }
6100              
6101 8 50       22 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin3::POSTMATCH()
6102 6         15 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6103             if ($ignorecase) {
6104             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::POSTMATCH())]}';
6105 0         0 }
6106             else {
6107             $char[$i] = '@{[Elatin3::POSTMATCH()]}';
6108             }
6109             }
6110              
6111 6 0       19 # ${ foo }
6112 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) {
6113             if ($ignorecase) {
6114             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6115             }
6116             }
6117              
6118 0         0 # ${ ... }
6119 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6120 0         0 $char[$i] = e_capture($1);
6121             if ($ignorecase) {
6122             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6123             }
6124             }
6125              
6126 0         0 # $scalar or @array
6127 21 100       61 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6128 21         122 $char[$i] = e_string($char[$i]);
6129             if ($ignorecase) {
6130             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6131             }
6132             }
6133              
6134 11 100 33     36 # quote character before ? + * {
    50          
6135             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6136             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6137 138         903 }
6138 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6139 0         0 my $char = $char[$i-1];
6140             if ($char[$i] eq '{') {
6141             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6142 0         0 }
6143             else {
6144             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6145             }
6146 0         0 }
6147             else {
6148             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6149             }
6150             }
6151             }
6152 127         516  
6153 642 50       1145 # make regexp string
6154 642 0 0     1320 $modifier =~ tr/i//d;
6155 0         0 if ($left_e > $right_e) {
6156             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6157             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6158 0         0 }
6159             else {
6160             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6161 0 50 33     0 }
6162 642         3344 }
6163             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6164             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6165 0         0 }
6166             else {
6167             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6168             }
6169             }
6170              
6171             #
6172             # double quote stuff
6173 642     180 0 5285 #
6174             sub qq_stuff {
6175             my($delimiter,$end_delimiter,$stuff) = @_;
6176 180 100       253  
6177 180         341 # scalar variable or array variable
6178             if ($stuff =~ /\A [\$\@] /oxms) {
6179             return $stuff;
6180             }
6181 100         327  
  80         168  
6182 80         206 # quote by delimiter
6183 80 50       181 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6184 80 50       120 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6185 80 50       110 next if $char eq $delimiter;
6186 80         138 next if $char eq $end_delimiter;
6187             if (not $octet{$char}) {
6188             return join '', 'qq', $char, $stuff, $char;
6189 80         282 }
6190             }
6191             return join '', 'qq', '<', $stuff, '>';
6192             }
6193              
6194             #
6195             # escape regexp (m'', qr'', and m''b, qr''b)
6196 0     10 0 0 #
6197 10   50     43 sub e_qr_q {
6198             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6199 10         41 $modifier ||= '';
6200 10 50       15  
6201 10         17 $modifier =~ tr/p//d;
6202 0         0 if ($modifier =~ /([adlu])/oxms) {
6203 0 0       0 my $line = 0;
6204 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6205 0         0 if ($filename ne __FILE__) {
6206             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6207             last;
6208 0         0 }
6209             }
6210             die qq{Unsupported modifier "$1" used at line $line.\n};
6211 0         0 }
6212              
6213             $slash = 'div';
6214 10 100       15  
    50          
6215 10         19 # literal null string pattern
6216 8         10 if ($string eq '') {
6217 8         8 $modifier =~ tr/bB//d;
6218             $modifier =~ tr/i//d;
6219             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6220             }
6221              
6222 8         37 # with /b /B modifier
6223             elsif ($modifier =~ tr/bB//d) {
6224             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6225             }
6226              
6227 0         0 # without /b /B modifier
6228             else {
6229             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6230             }
6231             }
6232              
6233             #
6234             # escape regexp (m'', qr'')
6235 2     2 0 7 #
6236             sub e_qr_qt {
6237 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6238              
6239             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6240 2         6  
6241             # split regexp
6242             my @char = $string =~ /\G((?>
6243             [^\\\[\$\@\/] |
6244             [\x00-\xFF] |
6245             \[\^ |
6246             \[\: (?>[a-z]+) \:\] |
6247             \[\:\^ (?>[a-z]+) \:\] |
6248             [\$\@\/] |
6249             \\ (?:$q_char) |
6250             (?:$q_char)
6251             ))/oxmsg;
6252 2         61  
6253 2 50 33     10 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6254             for (my $i=0; $i <= $#char; $i++) {
6255             if (0) {
6256             }
6257 2         15  
6258 0         0 # open character class [...]
6259 0 0       0 elsif ($char[$i] eq '[') {
6260 0         0 my $left = $i;
6261             if ($char[$i+1] eq ']') {
6262 0         0 $i++;
6263 0 0       0 }
6264 0         0 while (1) {
6265             if (++$i > $#char) {
6266 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6267 0         0 }
6268             if ($char[$i] eq ']') {
6269             my $right = $i;
6270 0         0  
6271             # [...]
6272 0         0 splice @char, $left, $right-$left+1, Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
6273 0         0  
6274             $i = $left;
6275             last;
6276             }
6277             }
6278             }
6279              
6280 0         0 # open character class [^...]
6281 0 0       0 elsif ($char[$i] eq '[^') {
6282 0         0 my $left = $i;
6283             if ($char[$i+1] eq ']') {
6284 0         0 $i++;
6285 0 0       0 }
6286 0         0 while (1) {
6287             if (++$i > $#char) {
6288 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6289 0         0 }
6290             if ($char[$i] eq ']') {
6291             my $right = $i;
6292 0         0  
6293             # [^...]
6294 0         0 splice @char, $left, $right-$left+1, Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6295 0         0  
6296             $i = $left;
6297             last;
6298             }
6299             }
6300             }
6301              
6302 0         0 # escape $ @ / and \
6303             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6304             $char[$i] = '\\' . $char[$i];
6305             }
6306              
6307 0         0 # rewrite character class or escape character
6308             elsif (my $char = character_class($char[$i],$modifier)) {
6309             $char[$i] = $char;
6310             }
6311              
6312 0 0       0 # /i modifier
6313 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin3::uc($char[$i]) ne Elatin3::fc($char[$i]))) {
6314             if (CORE::length(Elatin3::fc($char[$i])) == 1) {
6315             $char[$i] = '[' . Elatin3::uc($char[$i]) . Elatin3::fc($char[$i]) . ']';
6316 0         0 }
6317             else {
6318             $char[$i] = '(?:' . Elatin3::uc($char[$i]) . '|' . Elatin3::fc($char[$i]) . ')';
6319             }
6320             }
6321              
6322 0 0       0 # quote character before ? + * {
6323             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6324             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6325 0         0 }
6326             else {
6327             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6328             }
6329             }
6330 0         0 }
6331 2         5  
6332             $delimiter = '/';
6333 2         4 $end_delimiter = '/';
6334 2         2  
6335             $modifier =~ tr/i//d;
6336             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6337             }
6338              
6339             #
6340             # escape regexp (m''b, qr''b)
6341 2     0 0 14 #
6342             sub e_qr_qb {
6343             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6344 0         0  
6345             # split regexp
6346             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6347 0         0  
6348 0 0       0 # unescape character
    0          
6349             for (my $i=0; $i <= $#char; $i++) {
6350             if (0) {
6351             }
6352 0         0  
6353             # remain \\
6354             elsif ($char[$i] eq '\\\\') {
6355             }
6356              
6357 0         0 # escape $ @ / and \
6358             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6359             $char[$i] = '\\' . $char[$i];
6360             }
6361 0         0 }
6362 0         0  
6363 0         0 $delimiter = '/';
6364             $end_delimiter = '/';
6365             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6366             }
6367              
6368             #
6369             # escape regexp (s/here//)
6370 0     76 0 0 #
6371 76   100     227 sub e_s1 {
6372             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6373 76         315 $modifier ||= '';
6374 76 50       133  
6375 76         221 $modifier =~ tr/p//d;
6376 0         0 if ($modifier =~ /([adlu])/oxms) {
6377 0 0       0 my $line = 0;
6378 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6379 0         0 if ($filename ne __FILE__) {
6380             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6381             last;
6382 0         0 }
6383             }
6384             die qq{Unsupported modifier "$1" used at line $line.\n};
6385 0         0 }
6386              
6387             $slash = 'div';
6388 76 100       131  
    50          
6389 76         299 # literal null string pattern
6390 8         10 if ($string eq '') {
6391 8         9 $modifier =~ tr/bB//d;
6392             $modifier =~ tr/i//d;
6393             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6394             }
6395              
6396             # /b /B modifier
6397             elsif ($modifier =~ tr/bB//d) {
6398 8 0       46  
6399 0         0 # choice again delimiter
6400 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6401 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6402 0         0 my %octet = map {$_ => 1} @char;
6403 0         0 if (not $octet{')'}) {
6404             $delimiter = '(';
6405             $end_delimiter = ')';
6406 0         0 }
6407 0         0 elsif (not $octet{'}'}) {
6408             $delimiter = '{';
6409             $end_delimiter = '}';
6410 0         0 }
6411 0         0 elsif (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       0 else {
6420 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6421 0         0 if (not $octet{$char}) {
6422 0         0 $delimiter = $char;
6423             $end_delimiter = $char;
6424             last;
6425             }
6426             }
6427             }
6428 0         0 }
6429 0         0  
6430             my $prematch = '';
6431             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6432 0 100       0 }
6433 68         187  
6434             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6435             my $metachar = qr/[\@\\|[\]{^]/oxms;
6436 68         243  
6437             # split regexp
6438             my @char = $string =~ /\G((?>
6439             [^\\\$\@\[\(] |
6440             \\ (?>[1-9][0-9]*) |
6441             \\g (?>\s*) (?>[1-9][0-9]*) |
6442             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6443             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6444             \\x (?>[0-9A-Fa-f]{1,2}) |
6445             \\ (?>[0-7]{2,3}) |
6446             \\c [\x40-\x5F] |
6447             \\x\{ (?>[0-9A-Fa-f]+) \} |
6448             \\o\{ (?>[0-7]+) \} |
6449             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6450             \\ $q_char |
6451             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6452             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6453             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6454             [\$\@] $qq_variable |
6455             \$ (?>\s* [0-9]+) |
6456             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6457             \$ \$ (?![\w\{]) |
6458             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6459             \[\^ |
6460             \[\: (?>[a-z]+) :\] |
6461             \[\:\^ (?>[a-z]+) :\] |
6462             \(\? |
6463             $q_char
6464             ))/oxmsg;
6465 68 50       16579  
6466 68         458 # choice again delimiter
  0         0  
6467 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6468 0         0 my %octet = map {$_ => 1} @char;
6469 0         0 if (not $octet{')'}) {
6470             $delimiter = '(';
6471             $end_delimiter = ')';
6472 0         0 }
6473 0         0 elsif (not $octet{'}'}) {
6474             $delimiter = '{';
6475             $end_delimiter = '}';
6476 0         0 }
6477 0         0 elsif (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       0 else {
6486 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6487 0         0 if (not $octet{$char}) {
6488 0         0 $delimiter = $char;
6489             $end_delimiter = $char;
6490             last;
6491             }
6492             }
6493             }
6494             }
6495 0         0  
  68         137  
6496             # count '('
6497 253         426 my $parens = grep { $_ eq '(' } @char;
6498 68         92  
6499 68         102 my $left_e = 0;
6500             my $right_e = 0;
6501             for (my $i=0; $i <= $#char; $i++) {
6502 68 50 33     229  
    50 33        
    100          
    100          
    50          
    50          
6503 195         1184 # "\L\u" --> "\u\L"
6504             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6505             @char[$i,$i+1] = @char[$i+1,$i];
6506             }
6507              
6508 0         0 # "\U\l" --> "\l\U"
6509             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6510             @char[$i,$i+1] = @char[$i+1,$i];
6511             }
6512              
6513 0         0 # octal escape sequence
6514             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6515             $char[$i] = Elatin3::octchr($1);
6516             }
6517              
6518 1         5 # hexadecimal escape sequence
6519             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6520             $char[$i] = Elatin3::hexchr($1);
6521             }
6522              
6523             # \b{...} --> b\{...}
6524             # \B{...} --> B\{...}
6525             # \N{CHARNAME} --> N\{CHARNAME}
6526             # \p{PROPERTY} --> p\{PROPERTY}
6527 1         4 # \P{PROPERTY} --> P\{PROPERTY}
6528             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6529             $char[$i] = $1 . '\\' . $2;
6530             }
6531              
6532 0         0 # \p, \P, \X --> p, P, X
6533             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6534             $char[$i] = $1;
6535 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          
6536              
6537             if (0) {
6538             }
6539 195         662  
6540 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6541 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6542             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)) {
6543             $char[$i] .= join '', splice @char, $i+1, 3;
6544 0         0 }
6545             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)) {
6546             $char[$i] .= join '', splice @char, $i+1, 2;
6547 0         0 }
6548             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)) {
6549             $char[$i] .= join '', splice @char, $i+1, 1;
6550             }
6551             }
6552              
6553 0         0 # open character class [...]
6554 13 50       19 elsif ($char[$i] eq '[') {
6555 13         42 my $left = $i;
6556             if ($char[$i+1] eq ']') {
6557 0         0 $i++;
6558 13 50       17 }
6559 58         85 while (1) {
6560             if (++$i > $#char) {
6561 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6562 58         131 }
6563             if ($char[$i] eq ']') {
6564             my $right = $i;
6565 13 50       18  
6566 13         94 # [...]
  0         0  
6567             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6568             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin3::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6569 0         0 }
6570             else {
6571             splice @char, $left, $right-$left+1, Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
6572 13         65 }
6573 13         23  
6574             $i = $left;
6575             last;
6576             }
6577             }
6578             }
6579              
6580 13         35 # open character class [^...]
6581 0 0       0 elsif ($char[$i] eq '[^') {
6582 0         0 my $left = $i;
6583             if ($char[$i+1] eq ']') {
6584 0         0 $i++;
6585 0 0       0 }
6586 0         0 while (1) {
6587             if (++$i > $#char) {
6588 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6589 0         0 }
6590             if ($char[$i] eq ']') {
6591             my $right = $i;
6592 0 0       0  
6593 0         0 # [^...]
  0         0  
6594             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6595             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin3::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6596 0         0 }
6597             else {
6598             splice @char, $left, $right-$left+1, Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6599 0         0 }
6600 0         0  
6601             $i = $left;
6602             last;
6603             }
6604             }
6605             }
6606              
6607 0         0 # rewrite character class or escape character
6608             elsif (my $char = character_class($char[$i],$modifier)) {
6609             $char[$i] = $char;
6610             }
6611              
6612 7 50       14 # /i modifier
6613 3         5 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin3::uc($char[$i]) ne Elatin3::fc($char[$i]))) {
6614             if (CORE::length(Elatin3::fc($char[$i])) == 1) {
6615             $char[$i] = '[' . Elatin3::uc($char[$i]) . Elatin3::fc($char[$i]) . ']';
6616 3         6 }
6617             else {
6618             $char[$i] = '(?:' . Elatin3::uc($char[$i]) . '|' . Elatin3::fc($char[$i]) . ')';
6619             }
6620             }
6621              
6622 0 0       0 # \u \l \U \L \F \Q \E
6623 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6624             if ($right_e < $left_e) {
6625             $char[$i] = '\\' . $char[$i];
6626             }
6627 0         0 }
6628 0         0 elsif ($char[$i] eq '\u') {
6629             $char[$i] = '@{[Elatin3::ucfirst qq<';
6630             $left_e++;
6631 0         0 }
6632 0         0 elsif ($char[$i] eq '\l') {
6633             $char[$i] = '@{[Elatin3::lcfirst qq<';
6634             $left_e++;
6635 0         0 }
6636 0         0 elsif ($char[$i] eq '\U') {
6637             $char[$i] = '@{[Elatin3::uc qq<';
6638             $left_e++;
6639 0         0 }
6640 0         0 elsif ($char[$i] eq '\L') {
6641             $char[$i] = '@{[Elatin3::lc qq<';
6642             $left_e++;
6643 0         0 }
6644 0         0 elsif ($char[$i] eq '\F') {
6645             $char[$i] = '@{[Elatin3::fc qq<';
6646             $left_e++;
6647 0         0 }
6648 0         0 elsif ($char[$i] eq '\Q') {
6649             $char[$i] = '@{[CORE::quotemeta qq<';
6650             $left_e++;
6651 0 0       0 }
6652 0         0 elsif ($char[$i] eq '\E') {
6653 0         0 if ($right_e < $left_e) {
6654             $char[$i] = '>]}';
6655             $right_e++;
6656 0         0 }
6657             else {
6658             $char[$i] = '';
6659             }
6660 0         0 }
6661 0 0       0 elsif ($char[$i] eq '\Q') {
6662 0         0 while (1) {
6663             if (++$i > $#char) {
6664 0 0       0 last;
6665 0         0 }
6666             if ($char[$i] eq '\E') {
6667             last;
6668             }
6669             }
6670             }
6671             elsif ($char[$i] eq '\E') {
6672             }
6673              
6674             # \0 --> \0
6675             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6676             }
6677              
6678             # \g{N}, \g{-N}
6679              
6680             # P.108 Using Simple Patterns
6681             # in Chapter 7: In the World of Regular Expressions
6682             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6683              
6684             # P.221 Capturing
6685             # in Chapter 5: Pattern Matching
6686             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6687              
6688             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6689             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6690             }
6691              
6692             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6693             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6694             }
6695              
6696             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6697             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6698             }
6699              
6700             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6701             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6702             }
6703              
6704 0 0       0 # $0 --> $0
6705 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6706             if ($ignorecase) {
6707             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6708             }
6709 0 0       0 }
6710 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6711             if ($ignorecase) {
6712             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6713             }
6714             }
6715              
6716             # $$ --> $$
6717             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6718             }
6719              
6720             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6721 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6722 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6723 0         0 $char[$i] = e_capture($1);
6724             if ($ignorecase) {
6725             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6726             }
6727 0         0 }
6728 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6729 0         0 $char[$i] = e_capture($1);
6730             if ($ignorecase) {
6731             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6732             }
6733             }
6734              
6735 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6736 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) {
6737 0         0 $char[$i] = e_capture($1.'->'.$2);
6738             if ($ignorecase) {
6739             $char[$i] = '@{[Elatin3::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_brace)*? \} ) \z/oxms) {
6745 0         0 $char[$i] = e_capture($1.'->'.$2);
6746             if ($ignorecase) {
6747             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6748             }
6749             }
6750              
6751 0         0 # $$foo
6752 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6753 0         0 $char[$i] = e_capture($1);
6754             if ($ignorecase) {
6755             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6756             }
6757             }
6758              
6759 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin3::PREMATCH()
6760 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6761             if ($ignorecase) {
6762             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::PREMATCH())]}';
6763 0         0 }
6764             else {
6765             $char[$i] = '@{[Elatin3::PREMATCH()]}';
6766             }
6767             }
6768              
6769 4 50       14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin3::MATCH()
6770 4         14 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6771             if ($ignorecase) {
6772             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::MATCH())]}';
6773 0         0 }
6774             else {
6775             $char[$i] = '@{[Elatin3::MATCH()]}';
6776             }
6777             }
6778              
6779 4 50       14 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin3::POSTMATCH()
6780 3         13 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6781             if ($ignorecase) {
6782             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::POSTMATCH())]}';
6783 0         0 }
6784             else {
6785             $char[$i] = '@{[Elatin3::POSTMATCH()]}';
6786             }
6787             }
6788              
6789 3 0       10 # ${ foo }
6790 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) {
6791             if ($ignorecase) {
6792             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6793             }
6794             }
6795              
6796 0         0 # ${ ... }
6797 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6798 0         0 $char[$i] = e_capture($1);
6799             if ($ignorecase) {
6800             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6801             }
6802             }
6803              
6804 0         0 # $scalar or @array
6805 4 50       21 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6806 4         27 $char[$i] = e_string($char[$i]);
6807             if ($ignorecase) {
6808             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
6809             }
6810             }
6811              
6812 0 50       0 # quote character before ? + * {
6813             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6814             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6815 13         64 }
6816             else {
6817             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6818             }
6819             }
6820             }
6821 13         60  
6822 68         151 # make regexp string
6823 68 50       114 my $prematch = '';
6824 68         188 $modifier =~ tr/i//d;
6825             if ($left_e > $right_e) {
6826 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6827             }
6828             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6829             }
6830              
6831             #
6832             # escape regexp (s'here'' or s'here''b)
6833 68     21 0 737 #
6834 21   100     43 sub e_s1_q {
6835             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6836 21         66 $modifier ||= '';
6837 21 50       26  
6838 21         36 $modifier =~ tr/p//d;
6839 0         0 if ($modifier =~ /([adlu])/oxms) {
6840 0 0       0 my $line = 0;
6841 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6842 0         0 if ($filename ne __FILE__) {
6843             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6844             last;
6845 0         0 }
6846             }
6847             die qq{Unsupported modifier "$1" used at line $line.\n};
6848 0         0 }
6849              
6850             $slash = 'div';
6851 21 100       31  
    50          
6852 21         46 # literal null string pattern
6853 8         9 if ($string eq '') {
6854 8         10 $modifier =~ tr/bB//d;
6855             $modifier =~ tr/i//d;
6856             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6857             }
6858              
6859 8         43 # with /b /B modifier
6860             elsif ($modifier =~ tr/bB//d) {
6861             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6862             }
6863              
6864 0         0 # without /b /B modifier
6865             else {
6866             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6867             }
6868             }
6869              
6870             #
6871             # escape regexp (s'here'')
6872 13     13 0 31 #
6873             sub e_s1_qt {
6874 13 50       26 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6875              
6876             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6877 13         21  
6878             # split regexp
6879             my @char = $string =~ /\G((?>
6880             [^\\\[\$\@\/] |
6881             [\x00-\xFF] |
6882             \[\^ |
6883             \[\: (?>[a-z]+) \:\] |
6884             \[\:\^ (?>[a-z]+) \:\] |
6885             [\$\@\/] |
6886             \\ (?:$q_char) |
6887             (?:$q_char)
6888             ))/oxmsg;
6889 13         197  
6890 13 50 33     39 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6891             for (my $i=0; $i <= $#char; $i++) {
6892             if (0) {
6893             }
6894 25         98  
6895 0         0 # open character class [...]
6896 0 0       0 elsif ($char[$i] eq '[') {
6897 0         0 my $left = $i;
6898             if ($char[$i+1] eq ']') {
6899 0         0 $i++;
6900 0 0       0 }
6901 0         0 while (1) {
6902             if (++$i > $#char) {
6903 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6904 0         0 }
6905             if ($char[$i] eq ']') {
6906             my $right = $i;
6907 0         0  
6908             # [...]
6909 0         0 splice @char, $left, $right-$left+1, Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
6910 0         0  
6911             $i = $left;
6912             last;
6913             }
6914             }
6915             }
6916              
6917 0         0 # open character class [^...]
6918 0 0       0 elsif ($char[$i] eq '[^') {
6919 0         0 my $left = $i;
6920             if ($char[$i+1] eq ']') {
6921 0         0 $i++;
6922 0 0       0 }
6923 0         0 while (1) {
6924             if (++$i > $#char) {
6925 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6926 0         0 }
6927             if ($char[$i] eq ']') {
6928             my $right = $i;
6929 0         0  
6930             # [^...]
6931 0         0 splice @char, $left, $right-$left+1, Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6932 0         0  
6933             $i = $left;
6934             last;
6935             }
6936             }
6937             }
6938              
6939 0         0 # escape $ @ / and \
6940             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6941             $char[$i] = '\\' . $char[$i];
6942             }
6943              
6944 0         0 # rewrite character class or escape character
6945             elsif (my $char = character_class($char[$i],$modifier)) {
6946             $char[$i] = $char;
6947             }
6948              
6949 6 0       12 # /i modifier
6950 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin3::uc($char[$i]) ne Elatin3::fc($char[$i]))) {
6951             if (CORE::length(Elatin3::fc($char[$i])) == 1) {
6952             $char[$i] = '[' . Elatin3::uc($char[$i]) . Elatin3::fc($char[$i]) . ']';
6953 0         0 }
6954             else {
6955             $char[$i] = '(?:' . Elatin3::uc($char[$i]) . '|' . Elatin3::fc($char[$i]) . ')';
6956             }
6957             }
6958              
6959 0 0       0 # quote character before ? + * {
6960             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6961             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6962 0         0 }
6963             else {
6964             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6965             }
6966             }
6967 0         0 }
6968 13         22  
6969 13         18 $modifier =~ tr/i//d;
6970 13         17 $delimiter = '/';
6971 13         15 $end_delimiter = '/';
6972             my $prematch = '';
6973             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6974             }
6975              
6976             #
6977             # escape regexp (s'here''b)
6978 13     0 0 88 #
6979             sub e_s1_qb {
6980             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6981 0         0  
6982             # split regexp
6983             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6984 0         0  
6985 0 0       0 # unescape character
    0          
6986             for (my $i=0; $i <= $#char; $i++) {
6987             if (0) {
6988             }
6989 0         0  
6990             # remain \\
6991             elsif ($char[$i] eq '\\\\') {
6992             }
6993              
6994 0         0 # escape $ @ / and \
6995             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6996             $char[$i] = '\\' . $char[$i];
6997             }
6998 0         0 }
6999 0         0  
7000 0         0 $delimiter = '/';
7001 0         0 $end_delimiter = '/';
7002             my $prematch = '';
7003             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7004             }
7005              
7006             #
7007             # escape regexp (s''here')
7008 0     16 0 0 #
7009             sub e_s2_q {
7010 16         31 my($ope,$delimiter,$end_delimiter,$string) = @_;
7011              
7012 16         20 $slash = 'div';
7013 16         99  
7014 16 100       39 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7015             for (my $i=0; $i <= $#char; $i++) {
7016             if (0) {
7017             }
7018 9         27  
7019             # not escape \\
7020             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7021             }
7022              
7023 0         0 # escape $ @ / and \
7024             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7025             $char[$i] = '\\' . $char[$i];
7026             }
7027 5         14 }
7028              
7029             return join '', $ope, $delimiter, @char, $end_delimiter;
7030             }
7031              
7032             #
7033             # escape regexp (s/here/and here/modifier)
7034 16     97 0 50 #
7035 97   100     819 sub e_sub {
7036             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7037 97         380 $modifier ||= '';
7038 97 50       176  
7039 97         278 $modifier =~ tr/p//d;
7040 0         0 if ($modifier =~ /([adlu])/oxms) {
7041 0 0       0 my $line = 0;
7042 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7043 0         0 if ($filename ne __FILE__) {
7044             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7045             last;
7046 0         0 }
7047             }
7048             die qq{Unsupported modifier "$1" used at line $line.\n};
7049 0 100       0 }
7050 97         247  
7051 36         45 if ($variable eq '') {
7052             $variable = '$_';
7053             $bind_operator = ' =~ ';
7054 36         44 }
7055              
7056             $slash = 'div';
7057              
7058             # P.128 Start of match (or end of previous match): \G
7059             # P.130 Advanced Use of \G with Perl
7060             # in Chapter 3: Overview of Regular Expression Features and Flavors
7061             # P.312 Iterative Matching: Scalar Context, with /g
7062             # in Chapter 7: Perl
7063             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7064              
7065             # P.181 Where You Left Off: The \G Assertion
7066             # in Chapter 5: Pattern Matching
7067             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7068              
7069             # P.220 Where You Left Off: The \G Assertion
7070             # in Chapter 5: Pattern Matching
7071 97         156 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7072 97         140  
7073             my $e_modifier = $modifier =~ tr/e//d;
7074 97         236 my $r_modifier = $modifier =~ tr/r//d;
7075 97 50       219  
7076 97         233 my $my = '';
7077 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7078 0         0 $my = $variable;
7079             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7080             $variable =~ s/ = .+ \z//oxms;
7081 0         0 }
7082 97         269  
7083             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7084             $variable_basename =~ s/ \s+ \z//oxms;
7085 97         161  
7086 97 100       132 # quote replacement string
7087 97         238 my $e_replacement = '';
7088 17         34 if ($e_modifier >= 1) {
7089             $e_replacement = e_qq('', '', '', $replacement);
7090             $e_modifier--;
7091 17 100       26 }
7092 80         187 else {
7093             if ($delimiter2 eq "'") {
7094             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7095 16         30 }
7096             else {
7097             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7098             }
7099 64         180 }
7100              
7101             my $sub = '';
7102 97 100       159  
7103 97 100       197 # with /r
7104             if ($r_modifier) {
7105             if (0) {
7106             }
7107 8         16  
7108 0 50       0 # s///gr without multibyte anchoring
7109             elsif ($modifier =~ /g/oxms) {
7110             $sub = sprintf(
7111             # 1 2 3 4 5
7112             q,
7113              
7114             $variable, # 1
7115             ($delimiter1 eq "'") ? # 2
7116             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7117             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7118             $s_matched, # 3
7119             $e_replacement, # 4
7120             '$Elatin3::re_r=CORE::eval $Elatin3::re_r; ' x $e_modifier, # 5
7121             );
7122             }
7123              
7124             # s///r
7125 4         15 else {
7126              
7127 4 50       5 my $prematch = q{$`};
7128              
7129             $sub = sprintf(
7130             # 1 2 3 4 5 6 7
7131             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin3::re_r=%s; %s"%s$Elatin3::re_r$'" } : %s>,
7132              
7133             $variable, # 1
7134             ($delimiter1 eq "'") ? # 2
7135             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7136             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7137             $s_matched, # 3
7138             $e_replacement, # 4
7139             '$Elatin3::re_r=CORE::eval $Elatin3::re_r; ' x $e_modifier, # 5
7140             $prematch, # 6
7141             $variable, # 7
7142             );
7143             }
7144 4 50       10  
7145 8         22 # $var !~ s///r doesn't make sense
7146             if ($bind_operator =~ / !~ /oxms) {
7147             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7148             }
7149             }
7150              
7151 0 100       0 # without /r
7152             else {
7153             if (0) {
7154             }
7155 89         193  
7156 0 100       0 # s///g without multibyte anchoring
    100          
7157             elsif ($modifier =~ /g/oxms) {
7158             $sub = sprintf(
7159             # 1 2 3 4 5 6 7 8
7160             q,
7161              
7162             $variable, # 1
7163             ($delimiter1 eq "'") ? # 2
7164             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7165             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7166             $s_matched, # 3
7167             $e_replacement, # 4
7168             '$Elatin3::re_r=CORE::eval $Elatin3::re_r; ' x $e_modifier, # 5
7169             $variable, # 6
7170             $variable, # 7
7171             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7172             );
7173             }
7174              
7175             # s///
7176 22         69 else {
7177              
7178 67 100       223 my $prematch = q{$`};
    100          
7179              
7180             $sub = sprintf(
7181              
7182             ($bind_operator =~ / =~ /oxms) ?
7183              
7184             # 1 2 3 4 5 6 7 8
7185             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin3::re_r=%s; %s%s="%s$Elatin3::re_r$'"; 1 } : undef> :
7186              
7187             # 1 2 3 4 5 6 7 8
7188             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin3::re_r=%s; %s%s="%s$Elatin3::re_r$'"; undef }>,
7189              
7190             $variable, # 1
7191             $bind_operator, # 2
7192             ($delimiter1 eq "'") ? # 3
7193             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7194             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7195             $s_matched, # 4
7196             $e_replacement, # 5
7197             '$Elatin3::re_r=CORE::eval $Elatin3::re_r; ' x $e_modifier, # 6
7198             $variable, # 7
7199             $prematch, # 8
7200             );
7201             }
7202             }
7203 67 50       348  
7204 97         264 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7205             if ($my ne '') {
7206             $sub = "($my, $sub)[1]";
7207             }
7208 0         0  
7209 97         146 # clear s/// variable
7210             $sub_variable = '';
7211 97         126 $bind_operator = '';
7212              
7213             return $sub;
7214             }
7215              
7216             #
7217             # escape regexp of split qr//
7218 97     74 0 818 #
7219 74   100     330 sub e_split {
7220             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7221 74         343 $modifier ||= '';
7222 74 50       125  
7223 74         354 $modifier =~ tr/p//d;
7224 0         0 if ($modifier =~ /([adlu])/oxms) {
7225 0 0       0 my $line = 0;
7226 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7227 0         0 if ($filename ne __FILE__) {
7228             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7229             last;
7230 0         0 }
7231             }
7232             die qq{Unsupported modifier "$1" used at line $line.\n};
7233 0         0 }
7234              
7235             $slash = 'div';
7236 74 50       140  
7237 74         168 # /b /B modifier
7238             if ($modifier =~ tr/bB//d) {
7239             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7240 0 50       0 }
7241 74         184  
7242             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7243             my $metachar = qr/[\@\\|[\]{^]/oxms;
7244 74         266  
7245             # split regexp
7246             my @char = $string =~ /\G((?>
7247             [^\\\$\@\[\(] |
7248             \\x (?>[0-9A-Fa-f]{1,2}) |
7249             \\ (?>[0-7]{2,3}) |
7250             \\c [\x40-\x5F] |
7251             \\x\{ (?>[0-9A-Fa-f]+) \} |
7252             \\o\{ (?>[0-7]+) \} |
7253             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7254             \\ $q_char |
7255             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7256             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7257             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7258             [\$\@] $qq_variable |
7259             \$ (?>\s* [0-9]+) |
7260             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7261             \$ \$ (?![\w\{]) |
7262             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7263             \[\^ |
7264             \[\: (?>[a-z]+) :\] |
7265             \[\:\^ (?>[a-z]+) :\] |
7266             \(\? |
7267             $q_char
7268 74         9088 ))/oxmsg;
7269 74         238  
7270 74         107 my $left_e = 0;
7271             my $right_e = 0;
7272             for (my $i=0; $i <= $#char; $i++) {
7273 74 50 33     356  
    50 33        
    100          
    100          
    50          
    50          
7274 249         1249 # "\L\u" --> "\u\L"
7275             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7276             @char[$i,$i+1] = @char[$i+1,$i];
7277             }
7278              
7279 0         0 # "\U\l" --> "\l\U"
7280             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7281             @char[$i,$i+1] = @char[$i+1,$i];
7282             }
7283              
7284 0         0 # octal escape sequence
7285             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7286             $char[$i] = Elatin3::octchr($1);
7287             }
7288              
7289 1         4 # hexadecimal escape sequence
7290             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7291             $char[$i] = Elatin3::hexchr($1);
7292             }
7293              
7294             # \b{...} --> b\{...}
7295             # \B{...} --> B\{...}
7296             # \N{CHARNAME} --> N\{CHARNAME}
7297             # \p{PROPERTY} --> p\{PROPERTY}
7298 1         4 # \P{PROPERTY} --> P\{PROPERTY}
7299             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7300             $char[$i] = $1 . '\\' . $2;
7301             }
7302              
7303 0         0 # \p, \P, \X --> p, P, X
7304             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7305             $char[$i] = $1;
7306 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          
7307              
7308             if (0) {
7309             }
7310 249         803  
7311 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7312 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7313             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)) {
7314             $char[$i] .= join '', splice @char, $i+1, 3;
7315 0         0 }
7316             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)) {
7317             $char[$i] .= join '', splice @char, $i+1, 2;
7318 0         0 }
7319             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)) {
7320             $char[$i] .= join '', splice @char, $i+1, 1;
7321             }
7322             }
7323              
7324 0         0 # open character class [...]
7325 3 50       4 elsif ($char[$i] eq '[') {
7326 3         9 my $left = $i;
7327             if ($char[$i+1] eq ']') {
7328 0         0 $i++;
7329 3 50       4 }
7330 7         11 while (1) {
7331             if (++$i > $#char) {
7332 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7333 7         13 }
7334             if ($char[$i] eq ']') {
7335             my $right = $i;
7336 3 50       3  
7337 3         16 # [...]
  0         0  
7338             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7339             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin3::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7340 0         0 }
7341             else {
7342             splice @char, $left, $right-$left+1, Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
7343 3         13 }
7344 3         7  
7345             $i = $left;
7346             last;
7347             }
7348             }
7349             }
7350              
7351 3         8 # open character class [^...]
7352 0 0       0 elsif ($char[$i] eq '[^') {
7353 0         0 my $left = $i;
7354             if ($char[$i+1] eq ']') {
7355 0         0 $i++;
7356 0 0       0 }
7357 0         0 while (1) {
7358             if (++$i > $#char) {
7359 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7360 0         0 }
7361             if ($char[$i] eq ']') {
7362             my $right = $i;
7363 0 0       0  
7364 0         0 # [^...]
  0         0  
7365             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7366             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin3::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7367 0         0 }
7368             else {
7369             splice @char, $left, $right-$left+1, Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7370 0         0 }
7371 0         0  
7372             $i = $left;
7373             last;
7374             }
7375             }
7376             }
7377              
7378 0         0 # rewrite character class or escape character
7379             elsif (my $char = character_class($char[$i],$modifier)) {
7380             $char[$i] = $char;
7381             }
7382              
7383             # P.794 29.2.161. split
7384             # in Chapter 29: Functions
7385             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7386              
7387             # P.951 split
7388             # in Chapter 27: Functions
7389             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7390              
7391             # said "The //m modifier is assumed when you split on the pattern /^/",
7392             # but perl5.008 is not so. Therefore, this software adds //m.
7393             # (and so on)
7394              
7395 1         3 # split(m/^/) --> split(m/^/m)
7396             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7397             $modifier .= 'm';
7398             }
7399              
7400 7 0       22 # /i modifier
7401 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin3::uc($char[$i]) ne Elatin3::fc($char[$i]))) {
7402             if (CORE::length(Elatin3::fc($char[$i])) == 1) {
7403             $char[$i] = '[' . Elatin3::uc($char[$i]) . Elatin3::fc($char[$i]) . ']';
7404 0         0 }
7405             else {
7406             $char[$i] = '(?:' . Elatin3::uc($char[$i]) . '|' . Elatin3::fc($char[$i]) . ')';
7407             }
7408             }
7409              
7410 0 0       0 # \u \l \U \L \F \Q \E
7411 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7412             if ($right_e < $left_e) {
7413             $char[$i] = '\\' . $char[$i];
7414             }
7415 0         0 }
7416 0         0 elsif ($char[$i] eq '\u') {
7417             $char[$i] = '@{[Elatin3::ucfirst qq<';
7418             $left_e++;
7419 0         0 }
7420 0         0 elsif ($char[$i] eq '\l') {
7421             $char[$i] = '@{[Elatin3::lcfirst qq<';
7422             $left_e++;
7423 0         0 }
7424 0         0 elsif ($char[$i] eq '\U') {
7425             $char[$i] = '@{[Elatin3::uc qq<';
7426             $left_e++;
7427 0         0 }
7428 0         0 elsif ($char[$i] eq '\L') {
7429             $char[$i] = '@{[Elatin3::lc qq<';
7430             $left_e++;
7431 0         0 }
7432 0         0 elsif ($char[$i] eq '\F') {
7433             $char[$i] = '@{[Elatin3::fc qq<';
7434             $left_e++;
7435 0         0 }
7436 0         0 elsif ($char[$i] eq '\Q') {
7437             $char[$i] = '@{[CORE::quotemeta qq<';
7438             $left_e++;
7439 0 0       0 }
7440 0         0 elsif ($char[$i] eq '\E') {
7441 0         0 if ($right_e < $left_e) {
7442             $char[$i] = '>]}';
7443             $right_e++;
7444 0         0 }
7445             else {
7446             $char[$i] = '';
7447             }
7448 0         0 }
7449 0 0       0 elsif ($char[$i] eq '\Q') {
7450 0         0 while (1) {
7451             if (++$i > $#char) {
7452 0 0       0 last;
7453 0         0 }
7454             if ($char[$i] eq '\E') {
7455             last;
7456             }
7457             }
7458             }
7459             elsif ($char[$i] eq '\E') {
7460             }
7461              
7462 0 0       0 # $0 --> $0
7463 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7464             if ($ignorecase) {
7465             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7466             }
7467 0 0       0 }
7468 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7469             if ($ignorecase) {
7470             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7471             }
7472             }
7473              
7474             # $$ --> $$
7475             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7476             }
7477              
7478             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7479 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7480 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7481 0         0 $char[$i] = e_capture($1);
7482             if ($ignorecase) {
7483             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7484             }
7485 0         0 }
7486 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7487 0         0 $char[$i] = e_capture($1);
7488             if ($ignorecase) {
7489             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7490             }
7491             }
7492              
7493 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7494 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) {
7495 0         0 $char[$i] = e_capture($1.'->'.$2);
7496             if ($ignorecase) {
7497             $char[$i] = '@{[Elatin3::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_brace)*? \} ) \z/oxms) {
7503 0         0 $char[$i] = e_capture($1.'->'.$2);
7504             if ($ignorecase) {
7505             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7506             }
7507             }
7508              
7509 0         0 # $$foo
7510 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7511 0         0 $char[$i] = e_capture($1);
7512             if ($ignorecase) {
7513             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7514             }
7515             }
7516              
7517 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin3::PREMATCH()
7518 12         39 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7519             if ($ignorecase) {
7520             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::PREMATCH())]}';
7521 0         0 }
7522             else {
7523             $char[$i] = '@{[Elatin3::PREMATCH()]}';
7524             }
7525             }
7526              
7527 12 50       49 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin3::MATCH()
7528 12         61 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7529             if ($ignorecase) {
7530             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::MATCH())]}';
7531 0         0 }
7532             else {
7533             $char[$i] = '@{[Elatin3::MATCH()]}';
7534             }
7535             }
7536              
7537 12 50       53 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin3::POSTMATCH()
7538 9         26 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7539             if ($ignorecase) {
7540             $char[$i] = '@{[Elatin3::ignorecase(Elatin3::POSTMATCH())]}';
7541 0         0 }
7542             else {
7543             $char[$i] = '@{[Elatin3::POSTMATCH()]}';
7544             }
7545             }
7546              
7547 9 0       40 # ${ foo }
7548 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) {
7549             if ($ignorecase) {
7550             $char[$i] = '@{[Elatin3::ignorecase(' . $1 . ')]}';
7551             }
7552             }
7553              
7554 0         0 # ${ ... }
7555 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7556 0         0 $char[$i] = e_capture($1);
7557             if ($ignorecase) {
7558             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7559             }
7560             }
7561              
7562 0         0 # $scalar or @array
7563 3 50       11 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7564 3         13 $char[$i] = e_string($char[$i]);
7565             if ($ignorecase) {
7566             $char[$i] = '@{[Elatin3::ignorecase(' . $char[$i] . ')]}';
7567             }
7568             }
7569              
7570 0 50       0 # quote character before ? + * {
7571             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7572             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7573 1         7 }
7574             else {
7575             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7576             }
7577             }
7578             }
7579 0         0  
7580 74 50       257 # make regexp string
7581 74         151 $modifier =~ tr/i//d;
7582             if ($left_e > $right_e) {
7583 0         0 return join '', 'Elatin3::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7584             }
7585             return join '', 'Elatin3::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7586             }
7587              
7588             #
7589             # escape regexp of split qr''
7590 74     0 0 710 #
7591 0   0       sub e_split_q {
7592             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7593 0           $modifier ||= '';
7594 0 0          
7595 0           $modifier =~ tr/p//d;
7596 0           if ($modifier =~ /([adlu])/oxms) {
7597 0 0         my $line = 0;
7598 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7599 0           if ($filename ne __FILE__) {
7600             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7601             last;
7602 0           }
7603             }
7604             die qq{Unsupported modifier "$1" used at line $line.\n};
7605 0           }
7606              
7607             $slash = 'div';
7608 0 0          
7609 0           # /b /B modifier
7610             if ($modifier =~ tr/bB//d) {
7611             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7612 0 0         }
7613              
7614             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7615 0            
7616             # split regexp
7617             my @char = $string =~ /\G((?>
7618             [^\\\[] |
7619             [\x00-\xFF] |
7620             \[\^ |
7621             \[\: (?>[a-z]+) \:\] |
7622             \[\:\^ (?>[a-z]+) \:\] |
7623             \\ (?:$q_char) |
7624             (?:$q_char)
7625             ))/oxmsg;
7626 0            
7627 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7628             for (my $i=0; $i <= $#char; $i++) {
7629             if (0) {
7630             }
7631 0            
7632 0           # open character class [...]
7633 0 0         elsif ($char[$i] eq '[') {
7634 0           my $left = $i;
7635             if ($char[$i+1] eq ']') {
7636 0           $i++;
7637 0 0         }
7638 0           while (1) {
7639             if (++$i > $#char) {
7640 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7641 0           }
7642             if ($char[$i] eq ']') {
7643             my $right = $i;
7644 0            
7645             # [...]
7646 0           splice @char, $left, $right-$left+1, Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
7647 0            
7648             $i = $left;
7649             last;
7650             }
7651             }
7652             }
7653              
7654 0           # open character class [^...]
7655 0 0         elsif ($char[$i] eq '[^') {
7656 0           my $left = $i;
7657             if ($char[$i+1] eq ']') {
7658 0           $i++;
7659 0 0         }
7660 0           while (1) {
7661             if (++$i > $#char) {
7662 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7663 0           }
7664             if ($char[$i] eq ']') {
7665             my $right = $i;
7666 0            
7667             # [^...]
7668 0           splice @char, $left, $right-$left+1, Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7669 0            
7670             $i = $left;
7671             last;
7672             }
7673             }
7674             }
7675              
7676 0           # rewrite character class or escape character
7677             elsif (my $char = character_class($char[$i],$modifier)) {
7678             $char[$i] = $char;
7679             }
7680              
7681 0           # split(m/^/) --> split(m/^/m)
7682             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7683             $modifier .= 'm';
7684             }
7685              
7686 0 0         # /i modifier
7687 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin3::uc($char[$i]) ne Elatin3::fc($char[$i]))) {
7688             if (CORE::length(Elatin3::fc($char[$i])) == 1) {
7689             $char[$i] = '[' . Elatin3::uc($char[$i]) . Elatin3::fc($char[$i]) . ']';
7690 0           }
7691             else {
7692             $char[$i] = '(?:' . Elatin3::uc($char[$i]) . '|' . Elatin3::fc($char[$i]) . ')';
7693             }
7694             }
7695              
7696 0 0         # quote character before ? + * {
7697             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7698             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7699 0           }
7700             else {
7701             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7702             }
7703             }
7704 0           }
7705 0            
7706             $modifier =~ tr/i//d;
7707             return join '', 'Elatin3::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7708             }
7709              
7710             #
7711             # instead of Carp::carp
7712 0     0 0   #
7713 0           sub carp {
7714             my($package,$filename,$line) = caller(1);
7715             print STDERR "@_ at $filename line $line.\n";
7716             }
7717              
7718             #
7719             # instead of Carp::croak
7720 0     0 0   #
7721 0           sub croak {
7722 0           my($package,$filename,$line) = caller(1);
7723             print STDERR "@_ at $filename line $line.\n";
7724             die "\n";
7725             }
7726              
7727             #
7728             # instead of Carp::cluck
7729 0     0 0   #
7730 0           sub cluck {
7731 0           my $i = 0;
7732 0           my @cluck = ();
7733 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7734             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7735 0           $i++;
7736 0           }
7737 0           print STDERR CORE::reverse @cluck;
7738             print STDERR "\n";
7739             print STDERR @_;
7740             }
7741              
7742             #
7743             # instead of Carp::confess
7744 0     0 0   #
7745 0           sub confess {
7746 0           my $i = 0;
7747 0           my @confess = ();
7748 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7749             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7750 0           $i++;
7751 0           }
7752 0           print STDERR CORE::reverse @confess;
7753 0           print STDERR "\n";
7754             print STDERR @_;
7755             die "\n";
7756             }
7757              
7758             1;
7759              
7760             __END__