File Coverage

blib/lib/Elatin5.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 Elatin5;
2 204     204   1242 use strict;
  204         313  
  204         7325  
3             ######################################################################
4             #
5             # Elatin5 - Run-time routines for Latin5.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin5/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   2925 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         567  
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   1062 use vars qw($VERSION);
  204         359  
  204         33489  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1746 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         344 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         25607 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   14180 CORE::eval q{
  204     204   1236  
  204     68   754  
  204         24994  
  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       78695 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 (Elatin5::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Elatin5::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   1654 no strict qw(refs);
  204         360  
  204         16566  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1157 no strict qw(refs);
  204     0   441  
  204         36808  
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   1413 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         504  
  204         13162  
149 204     204   1440 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         454  
  204         313914  
150              
151             #
152             # Latin-5 character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # Latin-5 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 Elatin5 \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177              
178             %lc = (%lc,
179             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
180             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
181             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
182             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
183             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
184             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
185             "\xC6" => "\xE6", # LATIN LETTER AE
186             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
187             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
188             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
189             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
190             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
191             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
192             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
193             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
194             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
195             "\xD0" => "\xF0", # LATIN LETTER G WITH BREVE
196             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
197             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
198             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
199             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
200             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
201             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
202             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
203             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
204             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
205             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
206             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
207             "\xDE" => "\xFE", # LATIN LETTER S WITH CEDILLA
208             );
209              
210             %uc = (%uc,
211             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
212             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
213             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
214             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
215             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
216             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
217             "\xE6" => "\xC6", # LATIN LETTER AE
218             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
219             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
220             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
221             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
222             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
223             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
224             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
225             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
226             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
227             "\xF0" => "\xD0", # LATIN LETTER G WITH BREVE
228             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
229             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
230             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
231             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
232             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
233             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
234             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
235             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
236             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
237             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
238             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
239             "\xFE" => "\xDE", # LATIN LETTER S WITH CEDILLA
240             );
241              
242             %fc = (%fc,
243             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
244             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
245             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
246             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
247             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
248             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
249             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
250             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
251             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
252             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
253             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
254             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
255             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
256             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
257             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
258             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
259             "\xD0" => "\xF0", # LATIN CAPITAL LETTER G WITH BREVE --> LATIN SMALL LETTER G WITH BREVE
260             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
261             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
262             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
263             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
264             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
265             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
266             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
267             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
268             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
269             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
270             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
271              
272             # CaseFolding-6.1.0.txt
273             # Date: 2011-07-25, 21:21:56 GMT [MD]
274             #
275             # T: special case for uppercase I and dotted uppercase I
276             # - For non-Turkic languages, this mapping is normally not used.
277             # - For Turkic languages (tr, az), this mapping can be used instead of the normal mapping for these characters.
278             # Note that the Turkic mappings do not maintain canonical equivalence without additional processing.
279             # See the discussions of case mapping in the Unicode Standard for more information.
280              
281             #-------------------------------------------------------------------------------
282             "\xDD" => "\x69", # LATIN CAPITAL LETTER I WITH DOT ABOVE
283             # --> LATIN SMALL LETTER I (without COMBINING DOT ABOVE)
284             #-------------------------------------------------------------------------------
285              
286             "\xDE" => "\xFE", # LATIN CAPITAL LETTER S WITH CEDILLA --> LATIN SMALL LETTER S WITH CEDILLA
287             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
288             );
289             }
290              
291             else {
292             croak "Don't know my package name '@{[__PACKAGE__]}'";
293             }
294              
295             #
296             # @ARGV wildcard globbing
297             #
298             sub import {
299              
300 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
301 0         0 my @argv = ();
302 0         0 for (@ARGV) {
303              
304             # has space
305 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
306 0 0       0 if (my @glob = Elatin5::glob(qq{"$_"})) {
307 0         0 push @argv, @glob;
308             }
309             else {
310 0         0 push @argv, $_;
311             }
312             }
313              
314             # has wildcard metachar
315             elsif (/\A (?:$q_char)*? [*?] /oxms) {
316 0 0       0 if (my @glob = Elatin5::glob($_)) {
317 0         0 push @argv, @glob;
318             }
319             else {
320 0         0 push @argv, $_;
321             }
322             }
323              
324             # no wildcard globbing
325             else {
326 0         0 push @argv, $_;
327             }
328             }
329 0         0 @ARGV = @argv;
330             }
331              
332 0         0 *Char::ord = \&Latin5::ord;
333 0         0 *Char::ord_ = \&Latin5::ord_;
334 0         0 *Char::reverse = \&Latin5::reverse;
335 0         0 *Char::getc = \&Latin5::getc;
336 0         0 *Char::length = \&Latin5::length;
337 0         0 *Char::substr = \&Latin5::substr;
338 0         0 *Char::index = \&Latin5::index;
339 0         0 *Char::rindex = \&Latin5::rindex;
340 0         0 *Char::eval = \&Latin5::eval;
341 0         0 *Char::escape = \&Latin5::escape;
342 0         0 *Char::escape_token = \&Latin5::escape_token;
343 0         0 *Char::escape_script = \&Latin5::escape_script;
344             }
345              
346             # P.230 Care with Prototypes
347             # in Chapter 6: Subroutines
348             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
349             #
350             # If you aren't careful, you can get yourself into trouble with prototypes.
351             # But if you are careful, you can do a lot of neat things with them. This is
352             # all very powerful, of course, and should only be used in moderation to make
353             # the world a better place.
354              
355             # P.332 Care with Prototypes
356             # in Chapter 7: Subroutines
357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
358             #
359             # If you aren't careful, you can get yourself into trouble with prototypes.
360             # But if you are careful, you can do a lot of neat things with them. This is
361             # all very powerful, of course, and should only be used in moderation to make
362             # the world a better place.
363              
364             #
365             # Prototypes of subroutines
366             #
367       0     sub unimport {}
368             sub Elatin5::split(;$$$);
369             sub Elatin5::tr($$$$;$);
370             sub Elatin5::chop(@);
371             sub Elatin5::index($$;$);
372             sub Elatin5::rindex($$;$);
373             sub Elatin5::lcfirst(@);
374             sub Elatin5::lcfirst_();
375             sub Elatin5::lc(@);
376             sub Elatin5::lc_();
377             sub Elatin5::ucfirst(@);
378             sub Elatin5::ucfirst_();
379             sub Elatin5::uc(@);
380             sub Elatin5::uc_();
381             sub Elatin5::fc(@);
382             sub Elatin5::fc_();
383             sub Elatin5::ignorecase;
384             sub Elatin5::classic_character_class;
385             sub Elatin5::capture;
386             sub Elatin5::chr(;$);
387             sub Elatin5::chr_();
388             sub Elatin5::glob($);
389             sub Elatin5::glob_();
390              
391             sub Latin5::ord(;$);
392             sub Latin5::ord_();
393             sub Latin5::reverse(@);
394             sub Latin5::getc(;*@);
395             sub Latin5::length(;$);
396             sub Latin5::substr($$;$$);
397             sub Latin5::index($$;$);
398             sub Latin5::rindex($$;$);
399             sub Latin5::escape(;$);
400              
401             #
402             # Regexp work
403             #
404 204         15841 use vars qw(
405             $re_a
406             $re_t
407             $re_n
408             $re_r
409 204     204   1612 );
  204         373  
410              
411             #
412             # Character class
413             #
414 204         1934979 use vars qw(
415             $dot
416             $dot_s
417             $eD
418             $eS
419             $eW
420             $eH
421             $eV
422             $eR
423             $eN
424             $not_alnum
425             $not_alpha
426             $not_ascii
427             $not_blank
428             $not_cntrl
429             $not_digit
430             $not_graph
431             $not_lower
432             $not_lower_i
433             $not_print
434             $not_punct
435             $not_space
436             $not_upper
437             $not_upper_i
438             $not_word
439             $not_xdigit
440             $eb
441             $eB
442 204     204   1230 );
  204         425  
443              
444             ${Elatin5::dot} = qr{(?>[^\x0A])};
445             ${Elatin5::dot_s} = qr{(?>[\x00-\xFF])};
446             ${Elatin5::eD} = qr{(?>[^0-9])};
447              
448             # Vertical tabs are now whitespace
449             # \s in a regex now matches a vertical tab in all circumstances.
450             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
451             # ${Elatin5::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
452             # ${Elatin5::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
453             ${Elatin5::eS} = qr{(?>[^\s])};
454              
455             ${Elatin5::eW} = qr{(?>[^0-9A-Z_a-z])};
456             ${Elatin5::eH} = qr{(?>[^\x09\x20])};
457             ${Elatin5::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
458             ${Elatin5::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
459             ${Elatin5::eN} = qr{(?>[^\x0A])};
460             ${Elatin5::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
461             ${Elatin5::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
462             ${Elatin5::not_ascii} = qr{(?>[^\x00-\x7F])};
463             ${Elatin5::not_blank} = qr{(?>[^\x09\x20])};
464             ${Elatin5::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
465             ${Elatin5::not_digit} = qr{(?>[^\x30-\x39])};
466             ${Elatin5::not_graph} = qr{(?>[^\x21-\x7F])};
467             ${Elatin5::not_lower} = qr{(?>[^\x61-\x7A])};
468             ${Elatin5::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
469             # ${Elatin5::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
470             ${Elatin5::not_print} = qr{(?>[^\x20-\x7F])};
471             ${Elatin5::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
472             ${Elatin5::not_space} = qr{(?>[^\s\x0B])};
473             ${Elatin5::not_upper} = qr{(?>[^\x41-\x5A])};
474             ${Elatin5::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
475             # ${Elatin5::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
476             ${Elatin5::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
477             ${Elatin5::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
478             ${Elatin5::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))};
479             ${Elatin5::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]))};
480              
481             # avoid: Name "Elatin5::foo" used only once: possible typo at here.
482             ${Elatin5::dot} = ${Elatin5::dot};
483             ${Elatin5::dot_s} = ${Elatin5::dot_s};
484             ${Elatin5::eD} = ${Elatin5::eD};
485             ${Elatin5::eS} = ${Elatin5::eS};
486             ${Elatin5::eW} = ${Elatin5::eW};
487             ${Elatin5::eH} = ${Elatin5::eH};
488             ${Elatin5::eV} = ${Elatin5::eV};
489             ${Elatin5::eR} = ${Elatin5::eR};
490             ${Elatin5::eN} = ${Elatin5::eN};
491             ${Elatin5::not_alnum} = ${Elatin5::not_alnum};
492             ${Elatin5::not_alpha} = ${Elatin5::not_alpha};
493             ${Elatin5::not_ascii} = ${Elatin5::not_ascii};
494             ${Elatin5::not_blank} = ${Elatin5::not_blank};
495             ${Elatin5::not_cntrl} = ${Elatin5::not_cntrl};
496             ${Elatin5::not_digit} = ${Elatin5::not_digit};
497             ${Elatin5::not_graph} = ${Elatin5::not_graph};
498             ${Elatin5::not_lower} = ${Elatin5::not_lower};
499             ${Elatin5::not_lower_i} = ${Elatin5::not_lower_i};
500             ${Elatin5::not_print} = ${Elatin5::not_print};
501             ${Elatin5::not_punct} = ${Elatin5::not_punct};
502             ${Elatin5::not_space} = ${Elatin5::not_space};
503             ${Elatin5::not_upper} = ${Elatin5::not_upper};
504             ${Elatin5::not_upper_i} = ${Elatin5::not_upper_i};
505             ${Elatin5::not_word} = ${Elatin5::not_word};
506             ${Elatin5::not_xdigit} = ${Elatin5::not_xdigit};
507             ${Elatin5::eb} = ${Elatin5::eb};
508             ${Elatin5::eB} = ${Elatin5::eB};
509              
510             #
511             # Latin-5 split
512             #
513             sub Elatin5::split(;$$$) {
514              
515             # P.794 29.2.161. split
516             # in Chapter 29: Functions
517             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
518              
519             # P.951 split
520             # in Chapter 27: Functions
521             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
522              
523 0     0 0 0 my $pattern = $_[0];
524 0         0 my $string = $_[1];
525 0         0 my $limit = $_[2];
526              
527             # if $pattern is also omitted or is the literal space, " "
528 0 0       0 if (not defined $pattern) {
529 0         0 $pattern = ' ';
530             }
531              
532             # if $string is omitted, the function splits the $_ string
533 0 0       0 if (not defined $string) {
534 0 0       0 if (defined $_) {
535 0         0 $string = $_;
536             }
537             else {
538 0         0 $string = '';
539             }
540             }
541              
542 0         0 my @split = ();
543              
544             # when string is empty
545 0 0       0 if ($string eq '') {
    0          
546              
547             # resulting list value in list context
548 0 0       0 if (wantarray) {
549 0         0 return @split;
550             }
551              
552             # count of substrings in scalar context
553             else {
554 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
555 0         0 @_ = @split;
556 0         0 return scalar @_;
557             }
558             }
559              
560             # split's first argument is more consistently interpreted
561             #
562             # After some changes earlier in v5.17, split's behavior has been simplified:
563             # if the PATTERN argument evaluates to a string containing one space, it is
564             # treated the way that a literal string containing one space once was.
565             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
566              
567             # if $pattern is also omitted or is the literal space, " ", the function splits
568             # on whitespace, /\s+/, after skipping any leading whitespace
569             # (and so on)
570              
571             elsif ($pattern eq ' ') {
572 0 0       0 if (not defined $limit) {
573 0         0 return CORE::split(' ', $string);
574             }
575             else {
576 0         0 return CORE::split(' ', $string, $limit);
577             }
578             }
579              
580             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
581 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
582              
583             # a pattern capable of matching either the null string or something longer than the
584             # null string will split the value of $string into separate characters wherever it
585             # matches the null string between characters
586             # (and so on)
587              
588 0 0       0 if ('' =~ / \A $pattern \z /xms) {
589 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
590 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
591              
592             # P.1024 Appendix W.10 Multibyte Processing
593             # of ISBN 1-56592-224-7 CJKV Information Processing
594             # (and so on)
595              
596             # the //m modifier is assumed when you split on the pattern /^/
597             # (and so on)
598              
599             # V
600 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
601              
602             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
603             # is included in the resulting list, interspersed with the fields that are ordinarily returned
604             # (and so on)
605              
606 0         0 local $@;
607 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
608 0         0 push @split, CORE::eval('$' . $digit);
609             }
610             }
611             }
612              
613             else {
614 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
615              
616             # V
617 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
618 0         0 local $@;
619 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
620 0         0 push @split, CORE::eval('$' . $digit);
621             }
622             }
623             }
624             }
625              
626             elsif ($limit > 0) {
627 0 0       0 if ('' =~ / \A $pattern \z /xms) {
628 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
629 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
630              
631             # V
632 0 0       0 if ($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             else {
641 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
642 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
643              
644             # V
645 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
646 0         0 local $@;
647 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
648 0         0 push @split, CORE::eval('$' . $digit);
649             }
650             }
651             }
652             }
653             }
654              
655 0 0       0 if (CORE::length($string) > 0) {
656 0         0 push @split, $string;
657             }
658              
659             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
660 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
661 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
662 0         0 pop @split;
663             }
664             }
665              
666             # resulting list value in list context
667 0 0       0 if (wantarray) {
668 0         0 return @split;
669             }
670              
671             # count of substrings in scalar context
672             else {
673 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
674 0         0 @_ = @split;
675 0         0 return scalar @_;
676             }
677             }
678              
679             #
680             # get last subexpression offsets
681             #
682             sub _last_subexpression_offsets {
683 0     0   0 my $pattern = $_[0];
684              
685             # remove comment
686 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
687              
688 0         0 my $modifier = '';
689 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
690 0         0 $modifier = $1;
691 0         0 $modifier =~ s/-[A-Za-z]*//;
692             }
693              
694             # with /x modifier
695 0         0 my @char = ();
696 0 0       0 if ($modifier =~ /x/oxms) {
697 0         0 @char = $pattern =~ /\G((?>
698             [^\\\#\[\(] |
699             \\ $q_char |
700             \# (?>[^\n]*) $ |
701             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
702             \(\? |
703             $q_char
704             ))/oxmsg;
705             }
706              
707             # without /x modifier
708             else {
709 0         0 @char = $pattern =~ /\G((?>
710             [^\\\[\(] |
711             \\ $q_char |
712             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
713             \(\? |
714             $q_char
715             ))/oxmsg;
716             }
717              
718 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
719             }
720              
721             #
722             # Latin-5 transliteration (tr///)
723             #
724             sub Elatin5::tr($$$$;$) {
725              
726 0     0 0 0 my $bind_operator = $_[1];
727 0         0 my $searchlist = $_[2];
728 0         0 my $replacementlist = $_[3];
729 0   0     0 my $modifier = $_[4] || '';
730              
731 0 0       0 if ($modifier =~ /r/oxms) {
732 0 0       0 if ($bind_operator =~ / !~ /oxms) {
733 0         0 croak "Using !~ with tr///r doesn't make sense";
734             }
735             }
736              
737 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
738 0         0 my @searchlist = _charlist_tr($searchlist);
739 0         0 my @replacementlist = _charlist_tr($replacementlist);
740              
741 0         0 my %tr = ();
742 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
743 0 0       0 if (not exists $tr{$searchlist[$i]}) {
744 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
745 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
746             }
747             elsif ($modifier =~ /d/oxms) {
748 0         0 $tr{$searchlist[$i]} = '';
749             }
750             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
751 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
752             }
753             else {
754 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
755             }
756             }
757             }
758              
759 0         0 my $tr = 0;
760 0         0 my $replaced = '';
761 0 0       0 if ($modifier =~ /c/oxms) {
762 0         0 while (defined(my $char = shift @char)) {
763 0 0       0 if (not exists $tr{$char}) {
764 0 0       0 if (defined $replacementlist[0]) {
765 0         0 $replaced .= $replacementlist[0];
766             }
767 0         0 $tr++;
768 0 0       0 if ($modifier =~ /s/oxms) {
769 0   0     0 while (@char and (not exists $tr{$char[0]})) {
770 0         0 shift @char;
771 0         0 $tr++;
772             }
773             }
774             }
775             else {
776 0         0 $replaced .= $char;
777             }
778             }
779             }
780             else {
781 0         0 while (defined(my $char = shift @char)) {
782 0 0       0 if (exists $tr{$char}) {
783 0         0 $replaced .= $tr{$char};
784 0         0 $tr++;
785 0 0       0 if ($modifier =~ /s/oxms) {
786 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
787 0         0 shift @char;
788 0         0 $tr++;
789             }
790             }
791             }
792             else {
793 0         0 $replaced .= $char;
794             }
795             }
796             }
797              
798 0 0       0 if ($modifier =~ /r/oxms) {
799 0         0 return $replaced;
800             }
801             else {
802 0         0 $_[0] = $replaced;
803 0 0       0 if ($bind_operator =~ / !~ /oxms) {
804 0         0 return not $tr;
805             }
806             else {
807 0         0 return $tr;
808             }
809             }
810             }
811              
812             #
813             # Latin-5 chop
814             #
815             sub Elatin5::chop(@) {
816              
817 0     0 0 0 my $chop;
818 0 0       0 if (@_ == 0) {
819 0         0 my @char = /\G (?>$q_char) /oxmsg;
820 0         0 $chop = pop @char;
821 0         0 $_ = join '', @char;
822             }
823             else {
824 0         0 for (@_) {
825 0         0 my @char = /\G (?>$q_char) /oxmsg;
826 0         0 $chop = pop @char;
827 0         0 $_ = join '', @char;
828             }
829             }
830 0         0 return $chop;
831             }
832              
833             #
834             # Latin-5 index by octet
835             #
836             sub Elatin5::index($$;$) {
837              
838 0     0 1 0 my($str,$substr,$position) = @_;
839 0   0     0 $position ||= 0;
840 0         0 my $pos = 0;
841              
842 0         0 while ($pos < CORE::length($str)) {
843 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
844 0 0       0 if ($pos >= $position) {
845 0         0 return $pos;
846             }
847             }
848 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
849 0         0 $pos += CORE::length($1);
850             }
851             else {
852 0         0 $pos += 1;
853             }
854             }
855 0         0 return -1;
856             }
857              
858             #
859             # Latin-5 reverse index
860             #
861             sub Elatin5::rindex($$;$) {
862              
863 0     0 0 0 my($str,$substr,$position) = @_;
864 0   0     0 $position ||= CORE::length($str) - 1;
865 0         0 my $pos = 0;
866 0         0 my $rindex = -1;
867              
868 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
869 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
870 0         0 $rindex = $pos;
871             }
872 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
873 0         0 $pos += CORE::length($1);
874             }
875             else {
876 0         0 $pos += 1;
877             }
878             }
879 0         0 return $rindex;
880             }
881              
882             #
883             # Latin-5 lower case first with parameter
884             #
885             sub Elatin5::lcfirst(@) {
886 0 0   0 0 0 if (@_) {
887 0         0 my $s = shift @_;
888 0 0 0     0 if (@_ and wantarray) {
889 0         0 return Elatin5::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
890             }
891             else {
892 0         0 return Elatin5::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
893             }
894             }
895             else {
896 0         0 return Elatin5::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
897             }
898             }
899              
900             #
901             # Latin-5 lower case first without parameter
902             #
903             sub Elatin5::lcfirst_() {
904 0     0 0 0 return Elatin5::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
905             }
906              
907             #
908             # Latin-5 lower case with parameter
909             #
910             sub Elatin5::lc(@) {
911 0 0   0 0 0 if (@_) {
912 0         0 my $s = shift @_;
913 0 0 0     0 if (@_ and wantarray) {
914 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
915             }
916             else {
917 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
918             }
919             }
920             else {
921 0         0 return Elatin5::lc_();
922             }
923             }
924              
925             #
926             # Latin-5 lower case without parameter
927             #
928             sub Elatin5::lc_() {
929 0     0 0 0 my $s = $_;
930 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
931             }
932              
933             #
934             # Latin-5 upper case first with parameter
935             #
936             sub Elatin5::ucfirst(@) {
937 0 0   0 0 0 if (@_) {
938 0         0 my $s = shift @_;
939 0 0 0     0 if (@_ and wantarray) {
940 0         0 return Elatin5::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
941             }
942             else {
943 0         0 return Elatin5::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
944             }
945             }
946             else {
947 0         0 return Elatin5::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
948             }
949             }
950              
951             #
952             # Latin-5 upper case first without parameter
953             #
954             sub Elatin5::ucfirst_() {
955 0     0 0 0 return Elatin5::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
956             }
957              
958             #
959             # Latin-5 upper case with parameter
960             #
961             sub Elatin5::uc(@) {
962 0 50   174 0 0 if (@_) {
963 174         275 my $s = shift @_;
964 174 50 33     221 if (@_ and wantarray) {
965 174 0       306 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
966             }
967             else {
968 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         552  
969             }
970             }
971             else {
972 174         633 return Elatin5::uc_();
973             }
974             }
975              
976             #
977             # Latin-5 upper case without parameter
978             #
979             sub Elatin5::uc_() {
980 0     0 0 0 my $s = $_;
981 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
982             }
983              
984             #
985             # Latin-5 fold case with parameter
986             #
987             sub Elatin5::fc(@) {
988 0 50   197 0 0 if (@_) {
989 197         278 my $s = shift @_;
990 197 50 33     232 if (@_ and wantarray) {
991 197 0       334 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
992             }
993             else {
994 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         479  
995             }
996             }
997             else {
998 197         1083 return Elatin5::fc_();
999             }
1000             }
1001              
1002             #
1003             # Latin-5 fold case without parameter
1004             #
1005             sub Elatin5::fc_() {
1006 0     0 0 0 my $s = $_;
1007 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1008             }
1009              
1010             #
1011             # Latin-5 regexp capture
1012             #
1013             {
1014             sub Elatin5::capture {
1015 0     0 1 0 return $_[0];
1016             }
1017             }
1018              
1019             #
1020             # Latin-5 regexp ignore case modifier
1021             #
1022             sub Elatin5::ignorecase {
1023              
1024 0     0 0 0 my @string = @_;
1025 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1026              
1027             # ignore case of $scalar or @array
1028 0         0 for my $string (@string) {
1029              
1030             # split regexp
1031 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1032              
1033             # unescape character
1034 0         0 for (my $i=0; $i <= $#char; $i++) {
1035 0 0       0 next if not defined $char[$i];
1036              
1037             # open character class [...]
1038 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1039 0         0 my $left = $i;
1040              
1041             # [] make die "unmatched [] in regexp ...\n"
1042              
1043 0 0       0 if ($char[$i+1] eq ']') {
1044 0         0 $i++;
1045             }
1046              
1047 0         0 while (1) {
1048 0 0       0 if (++$i > $#char) {
1049 0         0 croak "Unmatched [] in regexp";
1050             }
1051 0 0       0 if ($char[$i] eq ']') {
1052 0         0 my $right = $i;
1053 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1054              
1055             # escape character
1056 0         0 for my $char (@charlist) {
1057 0 0       0 if (0) {
1058             }
1059              
1060 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1061 0         0 $char = '\\' . $char;
1062             }
1063             }
1064              
1065             # [...]
1066 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1067              
1068 0         0 $i = $left;
1069 0         0 last;
1070             }
1071             }
1072             }
1073              
1074             # open character class [^...]
1075             elsif ($char[$i] eq '[^') {
1076 0         0 my $left = $i;
1077              
1078             # [^] make die "unmatched [] in regexp ...\n"
1079              
1080 0 0       0 if ($char[$i+1] eq ']') {
1081 0         0 $i++;
1082             }
1083              
1084 0         0 while (1) {
1085 0 0       0 if (++$i > $#char) {
1086 0         0 croak "Unmatched [] in regexp";
1087             }
1088 0 0       0 if ($char[$i] eq ']') {
1089 0         0 my $right = $i;
1090 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1091              
1092             # escape character
1093 0         0 for my $char (@charlist) {
1094 0 0       0 if (0) {
1095             }
1096              
1097 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1098 0         0 $char = '\\' . $char;
1099             }
1100             }
1101              
1102             # [^...]
1103 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1104              
1105 0         0 $i = $left;
1106 0         0 last;
1107             }
1108             }
1109             }
1110              
1111             # rewrite classic character class or escape character
1112             elsif (my $char = classic_character_class($char[$i])) {
1113 0         0 $char[$i] = $char;
1114             }
1115              
1116             # with /i modifier
1117             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1118 0         0 my $uc = Elatin5::uc($char[$i]);
1119 0         0 my $fc = Elatin5::fc($char[$i]);
1120 0 0       0 if ($uc ne $fc) {
1121 0 0       0 if (CORE::length($fc) == 1) {
1122 0         0 $char[$i] = '[' . $uc . $fc . ']';
1123             }
1124             else {
1125 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1126             }
1127             }
1128             }
1129             }
1130              
1131             # characterize
1132 0         0 for (my $i=0; $i <= $#char; $i++) {
1133 0 0       0 next if not defined $char[$i];
1134              
1135 0 0       0 if (0) {
1136             }
1137              
1138             # quote character before ? + * {
1139 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1140 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1141 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1142             }
1143             }
1144             }
1145              
1146 0         0 $string = join '', @char;
1147             }
1148              
1149             # make regexp string
1150 0         0 return @string;
1151             }
1152              
1153             #
1154             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1155             #
1156             sub Elatin5::classic_character_class {
1157 0     1867 0 0 my($char) = @_;
1158              
1159             return {
1160             '\D' => '${Elatin5::eD}',
1161             '\S' => '${Elatin5::eS}',
1162             '\W' => '${Elatin5::eW}',
1163             '\d' => '[0-9]',
1164              
1165             # Before Perl 5.6, \s only matched the five whitespace characters
1166             # tab, newline, form-feed, carriage return, and the space character
1167             # itself, which, taken together, is the character class [\t\n\f\r ].
1168              
1169             # Vertical tabs are now whitespace
1170             # \s in a regex now matches a vertical tab in all circumstances.
1171             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1172             # \t \n \v \f \r space
1173             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1174             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1175             '\s' => '\s',
1176              
1177             '\w' => '[0-9A-Z_a-z]',
1178             '\C' => '[\x00-\xFF]',
1179             '\X' => 'X',
1180              
1181             # \h \v \H \V
1182              
1183             # P.114 Character Class Shortcuts
1184             # in Chapter 7: In the World of Regular Expressions
1185             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1186              
1187             # P.357 13.2.3 Whitespace
1188             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1189             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1190             #
1191             # 0x00009 CHARACTER TABULATION h s
1192             # 0x0000a LINE FEED (LF) vs
1193             # 0x0000b LINE TABULATION v
1194             # 0x0000c FORM FEED (FF) vs
1195             # 0x0000d CARRIAGE RETURN (CR) vs
1196             # 0x00020 SPACE h s
1197              
1198             # P.196 Table 5-9. Alphanumeric regex metasymbols
1199             # in Chapter 5. Pattern Matching
1200             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1201              
1202             # (and so on)
1203              
1204             '\H' => '${Elatin5::eH}',
1205             '\V' => '${Elatin5::eV}',
1206             '\h' => '[\x09\x20]',
1207             '\v' => '[\x0A\x0B\x0C\x0D]',
1208             '\R' => '${Elatin5::eR}',
1209              
1210             # \N
1211             #
1212             # http://perldoc.perl.org/perlre.html
1213             # Character Classes and other Special Escapes
1214             # Any character but \n (experimental). Not affected by /s modifier
1215              
1216             '\N' => '${Elatin5::eN}',
1217              
1218             # \b \B
1219              
1220             # P.180 Boundaries: The \b and \B Assertions
1221             # in Chapter 5: Pattern Matching
1222             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1223              
1224             # P.219 Boundaries: The \b and \B Assertions
1225             # in Chapter 5: Pattern Matching
1226             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1227              
1228             # \b really means (?:(?<=\w)(?!\w)|(?
1229             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1230             '\b' => '${Elatin5::eb}',
1231              
1232             # \B really means (?:(?<=\w)(?=\w)|(?
1233             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1234             '\B' => '${Elatin5::eB}',
1235              
1236 1867   100     2742 }->{$char} || '';
1237             }
1238              
1239             #
1240             # prepare Latin-5 characters per length
1241             #
1242              
1243             # 1 octet characters
1244             my @chars1 = ();
1245             sub chars1 {
1246 1867 0   0 0 64793 if (@chars1) {
1247 0         0 return @chars1;
1248             }
1249 0 0       0 if (exists $range_tr{1}) {
1250 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1251 0         0 while (my @range = splice(@ranges,0,1)) {
1252 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1253 0         0 push @chars1, pack 'C', $oct0;
1254             }
1255             }
1256             }
1257 0         0 return @chars1;
1258             }
1259              
1260             # 2 octets characters
1261             my @chars2 = ();
1262             sub chars2 {
1263 0 0   0 0 0 if (@chars2) {
1264 0         0 return @chars2;
1265             }
1266 0 0       0 if (exists $range_tr{2}) {
1267 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1268 0         0 while (my @range = splice(@ranges,0,2)) {
1269 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1270 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1271 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1272             }
1273             }
1274             }
1275             }
1276 0         0 return @chars2;
1277             }
1278              
1279             # 3 octets characters
1280             my @chars3 = ();
1281             sub chars3 {
1282 0 0   0 0 0 if (@chars3) {
1283 0         0 return @chars3;
1284             }
1285 0 0       0 if (exists $range_tr{3}) {
1286 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1287 0         0 while (my @range = splice(@ranges,0,3)) {
1288 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1289 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1290 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1291 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1292             }
1293             }
1294             }
1295             }
1296             }
1297 0         0 return @chars3;
1298             }
1299              
1300             # 4 octets characters
1301             my @chars4 = ();
1302             sub chars4 {
1303 0 0   0 0 0 if (@chars4) {
1304 0         0 return @chars4;
1305             }
1306 0 0       0 if (exists $range_tr{4}) {
1307 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1308 0         0 while (my @range = splice(@ranges,0,4)) {
1309 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1310 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1311 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1312 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1313 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1314             }
1315             }
1316             }
1317             }
1318             }
1319             }
1320 0         0 return @chars4;
1321             }
1322              
1323             #
1324             # Latin-5 open character list for tr
1325             #
1326             sub _charlist_tr {
1327              
1328 0     0   0 local $_ = shift @_;
1329              
1330             # unescape character
1331 0         0 my @char = ();
1332 0         0 while (not /\G \z/oxmsgc) {
1333 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1334 0         0 push @char, '\-';
1335             }
1336             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1337 0         0 push @char, CORE::chr(oct $1);
1338             }
1339             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(hex $1);
1341             }
1342             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1343 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1344             }
1345             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1346             push @char, {
1347             '\0' => "\0",
1348             '\n' => "\n",
1349             '\r' => "\r",
1350             '\t' => "\t",
1351             '\f' => "\f",
1352             '\b' => "\x08", # \b means backspace in character class
1353             '\a' => "\a",
1354             '\e' => "\e",
1355 0         0 }->{$1};
1356             }
1357             elsif (/\G \\ ($q_char) /oxmsgc) {
1358 0         0 push @char, $1;
1359             }
1360             elsif (/\G ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             }
1364              
1365             # join separated multiple-octet
1366 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1367              
1368             # unescape '-'
1369 0         0 my @i = ();
1370 0         0 for my $i (0 .. $#char) {
1371 0 0       0 if ($char[$i] eq '\-') {
    0          
1372 0         0 $char[$i] = '-';
1373             }
1374             elsif ($char[$i] eq '-') {
1375 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1376 0         0 push @i, $i;
1377             }
1378             }
1379             }
1380              
1381             # open character list (reverse for splice)
1382 0         0 for my $i (CORE::reverse @i) {
1383 0         0 my @range = ();
1384              
1385             # range error
1386 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1387 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1388             }
1389              
1390             # range of multiple-octet code
1391 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1392 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1393 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1394             }
1395             elsif (CORE::length($char[$i+1]) == 2) {
1396 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1397 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1398             }
1399             elsif (CORE::length($char[$i+1]) == 3) {
1400 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1401 0         0 push @range, chars2();
1402 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1403             }
1404             elsif (CORE::length($char[$i+1]) == 4) {
1405 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1406 0         0 push @range, chars2();
1407 0         0 push @range, chars3();
1408 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1409             }
1410             else {
1411 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1412             }
1413             }
1414             elsif (CORE::length($char[$i-1]) == 2) {
1415 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1416 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1417             }
1418             elsif (CORE::length($char[$i+1]) == 3) {
1419 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1420 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1421             }
1422             elsif (CORE::length($char[$i+1]) == 4) {
1423 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1424 0         0 push @range, chars3();
1425 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1426             }
1427             else {
1428 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1429             }
1430             }
1431             elsif (CORE::length($char[$i-1]) == 3) {
1432 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1433 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1434             }
1435             elsif (CORE::length($char[$i+1]) == 4) {
1436 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1437 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1438             }
1439             else {
1440 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1441             }
1442             }
1443             elsif (CORE::length($char[$i-1]) == 4) {
1444 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1445 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1446             }
1447             else {
1448 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1449             }
1450             }
1451             else {
1452 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1453             }
1454              
1455 0         0 splice @char, $i-1, 3, @range;
1456             }
1457              
1458 0         0 return @char;
1459             }
1460              
1461             #
1462             # Latin-5 open character class
1463             #
1464             sub _cc {
1465 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1466 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1467             }
1468             elsif (scalar(@_) == 1) {
1469 0         0 return sprintf('\x%02X',$_[0]);
1470             }
1471             elsif (scalar(@_) == 2) {
1472 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1473 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1474             }
1475             elsif ($_[0] == $_[1]) {
1476 0         0 return sprintf('\x%02X',$_[0]);
1477             }
1478             elsif (($_[0]+1) == $_[1]) {
1479 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1480             }
1481             else {
1482 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1483             }
1484             }
1485             else {
1486 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1487             }
1488             }
1489              
1490             #
1491             # Latin-5 octet range
1492             #
1493             sub _octets {
1494 0     182   0 my $length = shift @_;
1495              
1496 182 50       321 if ($length == 1) {
1497 182         377 my($a1) = unpack 'C', $_[0];
1498 182         610 my($z1) = unpack 'C', $_[1];
1499              
1500 182 50       339 if ($a1 > $z1) {
1501 182         356 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1502             }
1503              
1504 0 50       0 if ($a1 == $z1) {
    50          
1505 182         433 return sprintf('\x%02X',$a1);
1506             }
1507             elsif (($a1+1) == $z1) {
1508 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1509             }
1510             else {
1511 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1512             }
1513             }
1514             else {
1515 182         1149 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1516             }
1517             }
1518              
1519             #
1520             # Latin-5 range regexp
1521             #
1522             sub _range_regexp {
1523 0     182   0 my($length,$first,$last) = @_;
1524              
1525 182         381 my @range_regexp = ();
1526 182 50       231 if (not exists $range_tr{$length}) {
1527 182         425 return @range_regexp;
1528             }
1529              
1530 0         0 my @ranges = @{ $range_tr{$length} };
  182         255  
1531 182         394 while (my @range = splice(@ranges,0,$length)) {
1532 182         566 my $min = '';
1533 182         274 my $max = '';
1534 182         225 for (my $i=0; $i < $length; $i++) {
1535 182         772 $min .= pack 'C', $range[$i][0];
1536 182         629 $max .= pack 'C', $range[$i][-1];
1537             }
1538              
1539             # min___max
1540             # FIRST_____________LAST
1541             # (nothing)
1542              
1543 182 50 33     416 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1544             }
1545              
1546             # **********
1547             # min_________max
1548             # FIRST_____________LAST
1549             # **********
1550              
1551             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1552 182         1679 push @range_regexp, _octets($length,$first,$max,$min,$max);
1553             }
1554              
1555             # **********************
1556             # min________________max
1557             # FIRST_____________LAST
1558             # **********************
1559              
1560             elsif (($min eq $first) and ($max eq $last)) {
1561 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1562             }
1563              
1564             # *********
1565             # min___max
1566             # FIRST_____________LAST
1567             # *********
1568              
1569             elsif (($first le $min) and ($max le $last)) {
1570 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1571             }
1572              
1573             # **********************
1574             # min__________________________max
1575             # FIRST_____________LAST
1576             # **********************
1577              
1578             elsif (($min le $first) and ($last le $max)) {
1579 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1580             }
1581              
1582             # *********
1583             # min________max
1584             # FIRST_____________LAST
1585             # *********
1586              
1587             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1588 182         456 push @range_regexp, _octets($length,$min,$last,$min,$max);
1589             }
1590              
1591             # min___max
1592             # FIRST_____________LAST
1593             # (nothing)
1594              
1595             elsif ($last lt $min) {
1596             }
1597              
1598             else {
1599 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1600             }
1601             }
1602              
1603 0         0 return @range_regexp;
1604             }
1605              
1606             #
1607             # Latin-5 open character list for qr and not qr
1608             #
1609             sub _charlist {
1610              
1611 182     358   412 my $modifier = pop @_;
1612 358         624 my @char = @_;
1613              
1614 358 100       765 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1615              
1616             # unescape character
1617 358         794 for (my $i=0; $i <= $#char; $i++) {
1618              
1619             # escape - to ...
1620 358 100 100     1288 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1621 1125 100 100     8228 if ((0 < $i) and ($i < $#char)) {
1622 206         943 $char[$i] = '...';
1623             }
1624             }
1625              
1626             # octal escape sequence
1627             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1628 182         371 $char[$i] = octchr($1);
1629             }
1630              
1631             # hexadecimal escape sequence
1632             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1633 0         0 $char[$i] = hexchr($1);
1634             }
1635              
1636             # \b{...} --> b\{...}
1637             # \B{...} --> B\{...}
1638             # \N{CHARNAME} --> N\{CHARNAME}
1639             # \p{PROPERTY} --> p\{PROPERTY}
1640             # \P{PROPERTY} --> P\{PROPERTY}
1641             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1642 0         0 $char[$i] = $1 . '\\' . $2;
1643             }
1644              
1645             # \p, \P, \X --> p, P, X
1646             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1647 0         0 $char[$i] = $1;
1648             }
1649              
1650             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1651 0         0 $char[$i] = CORE::chr oct $1;
1652             }
1653             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1654 0         0 $char[$i] = CORE::chr hex $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1657 22         98 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1658             }
1659             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1660             $char[$i] = {
1661             '\0' => "\0",
1662             '\n' => "\n",
1663             '\r' => "\r",
1664             '\t' => "\t",
1665             '\f' => "\f",
1666             '\b' => "\x08", # \b means backspace in character class
1667             '\a' => "\a",
1668             '\e' => "\e",
1669             '\d' => '[0-9]',
1670              
1671             # Vertical tabs are now whitespace
1672             # \s in a regex now matches a vertical tab in all circumstances.
1673             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1674             # \t \n \v \f \r space
1675             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1676             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1677             '\s' => '\s',
1678              
1679             '\w' => '[0-9A-Z_a-z]',
1680             '\D' => '${Elatin5::eD}',
1681             '\S' => '${Elatin5::eS}',
1682             '\W' => '${Elatin5::eW}',
1683              
1684             '\H' => '${Elatin5::eH}',
1685             '\V' => '${Elatin5::eV}',
1686             '\h' => '[\x09\x20]',
1687             '\v' => '[\x0A\x0B\x0C\x0D]',
1688             '\R' => '${Elatin5::eR}',
1689              
1690 0         0 }->{$1};
1691             }
1692              
1693             # POSIX-style character classes
1694             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1695             $char[$i] = {
1696              
1697             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1698             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1699             '[:^lower:]' => '${Elatin5::not_lower_i}',
1700             '[:^upper:]' => '${Elatin5::not_upper_i}',
1701              
1702 25         457 }->{$1};
1703             }
1704             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1705             $char[$i] = {
1706              
1707             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1708             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1709             '[:ascii:]' => '[\x00-\x7F]',
1710             '[:blank:]' => '[\x09\x20]',
1711             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1712             '[:digit:]' => '[\x30-\x39]',
1713             '[:graph:]' => '[\x21-\x7F]',
1714             '[:lower:]' => '[\x61-\x7A]',
1715             '[:print:]' => '[\x20-\x7F]',
1716             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1717              
1718             # P.174 POSIX-Style Character Classes
1719             # in Chapter 5: Pattern Matching
1720             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1721              
1722             # P.311 11.2.4 Character Classes and other Special Escapes
1723             # in Chapter 11: perlre: Perl regular expressions
1724             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1725              
1726             # P.210 POSIX-Style Character Classes
1727             # in Chapter 5: Pattern Matching
1728             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1729              
1730             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1731              
1732             '[:upper:]' => '[\x41-\x5A]',
1733             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1734             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1735             '[:^alnum:]' => '${Elatin5::not_alnum}',
1736             '[:^alpha:]' => '${Elatin5::not_alpha}',
1737             '[:^ascii:]' => '${Elatin5::not_ascii}',
1738             '[:^blank:]' => '${Elatin5::not_blank}',
1739             '[:^cntrl:]' => '${Elatin5::not_cntrl}',
1740             '[:^digit:]' => '${Elatin5::not_digit}',
1741             '[:^graph:]' => '${Elatin5::not_graph}',
1742             '[:^lower:]' => '${Elatin5::not_lower}',
1743             '[:^print:]' => '${Elatin5::not_print}',
1744             '[:^punct:]' => '${Elatin5::not_punct}',
1745             '[:^space:]' => '${Elatin5::not_space}',
1746             '[:^upper:]' => '${Elatin5::not_upper}',
1747             '[:^word:]' => '${Elatin5::not_word}',
1748             '[:^xdigit:]' => '${Elatin5::not_xdigit}',
1749              
1750 8         65 }->{$1};
1751             }
1752             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1753 70         1521 $char[$i] = $1;
1754             }
1755             }
1756              
1757             # open character list
1758 7         32 my @singleoctet = ();
1759 358         615 my @multipleoctet = ();
1760 358         489 for (my $i=0; $i <= $#char; ) {
1761              
1762             # escaped -
1763 358 100 100     841 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1764 943         4241 $i += 1;
1765 182         250 next;
1766             }
1767              
1768             # make range regexp
1769             elsif ($char[$i] eq '...') {
1770              
1771             # range error
1772 182 50       310 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1773 182         689 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1774             }
1775             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1776 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1777 182         634 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1778             }
1779             }
1780              
1781             # make range regexp per length
1782 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1783 182         541 my @regexp = ();
1784              
1785             # is first and last
1786 182 50 33     276 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1787 182         623 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1788             }
1789              
1790             # is first
1791             elsif ($length == CORE::length($char[$i-1])) {
1792 182         470 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1793             }
1794              
1795             # is inside in first and last
1796             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1797 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1798             }
1799              
1800             # is last
1801             elsif ($length == CORE::length($char[$i+1])) {
1802 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1803             }
1804              
1805             else {
1806 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1807             }
1808              
1809 0 50       0 if ($length == 1) {
1810 182         343 push @singleoctet, @regexp;
1811             }
1812             else {
1813 182         410 push @multipleoctet, @regexp;
1814             }
1815             }
1816              
1817 0         0 $i += 2;
1818             }
1819              
1820             # with /i modifier
1821             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1822 182 100       359 if ($modifier =~ /i/oxms) {
1823 493         714 my $uc = Elatin5::uc($char[$i]);
1824 24         51 my $fc = Elatin5::fc($char[$i]);
1825 24 100       47 if ($uc ne $fc) {
1826 24 50       48 if (CORE::length($fc) == 1) {
1827 12         22 push @singleoctet, $uc, $fc;
1828             }
1829             else {
1830 12         23 push @singleoctet, $uc;
1831 0         0 push @multipleoctet, $fc;
1832             }
1833             }
1834             else {
1835 0         0 push @singleoctet, $char[$i];
1836             }
1837             }
1838             else {
1839 12         26 push @singleoctet, $char[$i];
1840             }
1841 469         804 $i += 1;
1842             }
1843              
1844             # single character of single octet code
1845             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1846 493         779 push @singleoctet, "\t", "\x20";
1847 0         0 $i += 1;
1848             }
1849             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1850 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1851 0         0 $i += 1;
1852             }
1853             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1854 0         0 push @singleoctet, $char[$i];
1855 2         5 $i += 1;
1856             }
1857              
1858             # single character of multiple-octet code
1859             else {
1860 2         6 push @multipleoctet, $char[$i];
1861 84         179 $i += 1;
1862             }
1863             }
1864              
1865             # quote metachar
1866 84         159 for (@singleoctet) {
1867 358 50       715 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1868 689         3138 $_ = '-';
1869             }
1870             elsif (/\A \n \z/oxms) {
1871 0         0 $_ = '\n';
1872             }
1873             elsif (/\A \r \z/oxms) {
1874 8         15 $_ = '\r';
1875             }
1876             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1877 8         16 $_ = sprintf('\x%02X', CORE::ord $1);
1878             }
1879             elsif (/\A [\x00-\xFF] \z/oxms) {
1880 60         226 $_ = quotemeta $_;
1881             }
1882             }
1883              
1884             # return character list
1885 429         691 return \@singleoctet, \@multipleoctet;
1886             }
1887              
1888             #
1889             # Latin-5 octal escape sequence
1890             #
1891             sub octchr {
1892 358     5 0 1182 my($octdigit) = @_;
1893              
1894 5         12 my @binary = ();
1895 5         9 for my $octal (split(//,$octdigit)) {
1896             push @binary, {
1897             '0' => '000',
1898             '1' => '001',
1899             '2' => '010',
1900             '3' => '011',
1901             '4' => '100',
1902             '5' => '101',
1903             '6' => '110',
1904             '7' => '111',
1905 5         32 }->{$octal};
1906             }
1907 50         190 my $binary = join '', @binary;
1908              
1909             my $octchr = {
1910             # 1234567
1911             1 => pack('B*', "0000000$binary"),
1912             2 => pack('B*', "000000$binary"),
1913             3 => pack('B*', "00000$binary"),
1914             4 => pack('B*', "0000$binary"),
1915             5 => pack('B*', "000$binary"),
1916             6 => pack('B*', "00$binary"),
1917             7 => pack('B*', "0$binary"),
1918             0 => pack('B*', "$binary"),
1919              
1920 5         14 }->{CORE::length($binary) % 8};
1921              
1922 5         69 return $octchr;
1923             }
1924              
1925             #
1926             # Latin-5 hexadecimal escape sequence
1927             #
1928             sub hexchr {
1929 5     5 0 21 my($hexdigit) = @_;
1930              
1931             my $hexchr = {
1932             1 => pack('H*', "0$hexdigit"),
1933             0 => pack('H*', "$hexdigit"),
1934              
1935 5         15 }->{CORE::length($_[0]) % 2};
1936              
1937 5         41 return $hexchr;
1938             }
1939              
1940             #
1941             # Latin-5 open character list for qr
1942             #
1943             sub charlist_qr {
1944              
1945 5     314 0 19 my $modifier = pop @_;
1946 314         619 my @char = @_;
1947              
1948 314         844 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1949 314         894 my @singleoctet = @$singleoctet;
1950 314         652 my @multipleoctet = @$multipleoctet;
1951              
1952             # return character list
1953 314 100       468 if (scalar(@singleoctet) >= 1) {
1954              
1955             # with /i modifier
1956 314 100       715 if ($modifier =~ m/i/oxms) {
1957 236         524 my %singleoctet_ignorecase = ();
1958 22         36 for (@singleoctet) {
1959 22   100     42 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1960 46         225 for my $ord (hex($1) .. hex($2)) {
1961 46         137 my $char = CORE::chr($ord);
1962 66         116 my $uc = Elatin5::uc($char);
1963 66         95 my $fc = Elatin5::fc($char);
1964 66 100       109 if ($uc eq $fc) {
1965 66         111 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1966             }
1967             else {
1968 12 50       76 if (CORE::length($fc) == 1) {
1969 54         84 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1970 54         106 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1971             }
1972             else {
1973 54         200 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1974 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1975             }
1976             }
1977             }
1978             }
1979 0 50       0 if ($_ ne '') {
1980 46         103 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1981             }
1982             }
1983 0         0 my $i = 0;
1984 22         26 my @singleoctet_ignorecase = ();
1985 22         32 for my $ord (0 .. 255) {
1986 22 100       35 if (exists $singleoctet_ignorecase{$ord}) {
1987 5632         6734 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         101  
1988             }
1989             else {
1990 96         232 $i++;
1991             }
1992             }
1993 5536         5802 @singleoctet = ();
1994 22         36 for my $range (@singleoctet_ignorecase) {
1995 22 100       69 if (ref $range) {
1996 3648 100       5867 if (scalar(@{$range}) == 1) {
  56 50       56  
1997 56         97 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         44  
1998             }
1999 36         124 elsif (scalar(@{$range}) == 2) {
2000 20         28 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2001             }
2002             else {
2003 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         25  
  20         22  
2004             }
2005             }
2006             }
2007             }
2008              
2009 20         75 my $not_anchor = '';
2010              
2011 236         389 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2012             }
2013 236 100       632 if (scalar(@multipleoctet) >= 2) {
2014 314         751 return '(?:' . join('|', @multipleoctet) . ')';
2015             }
2016             else {
2017 6         32 return $multipleoctet[0];
2018             }
2019             }
2020              
2021             #
2022             # Latin-5 open character list for not qr
2023             #
2024             sub charlist_not_qr {
2025              
2026 308     44 0 1388 my $modifier = pop @_;
2027 44         120 my @char = @_;
2028              
2029 44         107 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2030 44         127 my @singleoctet = @$singleoctet;
2031 44         96 my @multipleoctet = @$multipleoctet;
2032              
2033             # with /i modifier
2034 44 100       66 if ($modifier =~ m/i/oxms) {
2035 44         120 my %singleoctet_ignorecase = ();
2036 10         11 for (@singleoctet) {
2037 10   66     14 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2038 10         44 for my $ord (hex($1) .. hex($2)) {
2039 10         31 my $char = CORE::chr($ord);
2040 30         47 my $uc = Elatin5::uc($char);
2041 30         42 my $fc = Elatin5::fc($char);
2042 30 50       44 if ($uc eq $fc) {
2043 30         48 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2044             }
2045             else {
2046 0 50       0 if (CORE::length($fc) == 1) {
2047 30         37 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2048 30         67 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2049             }
2050             else {
2051 30         95 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2052 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2053             }
2054             }
2055             }
2056             }
2057 0 50       0 if ($_ ne '') {
2058 10         28 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2059             }
2060             }
2061 0         0 my $i = 0;
2062 10         11 my @singleoctet_ignorecase = ();
2063 10         16 for my $ord (0 .. 255) {
2064 10 100       17 if (exists $singleoctet_ignorecase{$ord}) {
2065 2560         2861 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         59  
2066             }
2067             else {
2068 60         99 $i++;
2069             }
2070             }
2071 2500         2443 @singleoctet = ();
2072 10         15 for my $range (@singleoctet_ignorecase) {
2073 10 100       25 if (ref $range) {
2074 960 50       1422 if (scalar(@{$range}) == 1) {
  20 50       20  
2075 20         32 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2076             }
2077 0         0 elsif (scalar(@{$range}) == 2) {
2078 20         25 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2079             }
2080             else {
2081 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         24  
  20         26  
2082             }
2083             }
2084             }
2085             }
2086              
2087             # return character list
2088 20 50       70 if (scalar(@multipleoctet) >= 1) {
2089 44 0       114 if (scalar(@singleoctet) >= 1) {
2090              
2091             # any character other than multiple-octet and single octet character class
2092 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2093             }
2094             else {
2095              
2096             # any character other than multiple-octet character class
2097 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2098             }
2099             }
2100             else {
2101 0 50       0 if (scalar(@singleoctet) >= 1) {
2102              
2103             # any character other than single octet character class
2104 44         89 return '(?:[^' . join('', @singleoctet) . '])';
2105             }
2106             else {
2107              
2108             # any character
2109 44         243 return "(?:$your_char)";
2110             }
2111             }
2112             }
2113              
2114             #
2115             # open file in read mode
2116             #
2117             sub _open_r {
2118 0     408   0 my(undef,$file) = @_;
2119 204     204   2189 use Fcntl qw(O_RDONLY);
  204         833  
  204         26413  
2120 408         1117 return CORE::sysopen($_[0], $file, &O_RDONLY);
2121             }
2122              
2123             #
2124             # open file in append mode
2125             #
2126             sub _open_a {
2127 408     204   16567 my(undef,$file) = @_;
2128 204     204   1565 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         420  
  204         597306  
2129 204         633 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2130             }
2131              
2132             #
2133             # safe system
2134             #
2135             sub _systemx {
2136              
2137             # P.707 29.2.33. exec
2138             # in Chapter 29: Functions
2139             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2140             #
2141             # Be aware that in older releases of Perl, exec (and system) did not flush
2142             # your output buffer, so you needed to enable command buffering by setting $|
2143             # on one or more filehandles to avoid lost output in the case of exec, or
2144             # misordererd output in the case of system. This situation was largely remedied
2145             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2146              
2147             # P.855 exec
2148             # in Chapter 27: Functions
2149             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2150             #
2151             # In very old release of Perl (before v5.6), exec (and system) did not flush
2152             # your output buffer, so you needed to enable command buffering by setting $|
2153             # on one or more filehandles to avoid lost output with exec or misordered
2154             # output with system.
2155              
2156 204     204   43822 $| = 1;
2157              
2158             # P.565 23.1.2. Cleaning Up Your Environment
2159             # in Chapter 23: Security
2160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2161              
2162             # P.656 Cleaning Up Your Environment
2163             # in Chapter 20: Security
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165              
2166             # local $ENV{'PATH'} = '.';
2167 204         655 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2168              
2169             # P.707 29.2.33. exec
2170             # in Chapter 29: Functions
2171             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2172             #
2173             # As we mentioned earlier, exec treats a discrete list of arguments as an
2174             # indication that it should bypass shell processing. However, there is one
2175             # place where you might still get tripped up. The exec call (and system, too)
2176             # will not distinguish between a single scalar argument and an array containing
2177             # only one element.
2178             #
2179             # @args = ("echo surprise"); # just one element in list
2180             # exec @args # still subject to shell escapes
2181             # or die "exec: $!"; # because @args == 1
2182             #
2183             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2184             # first argument as the pathname, which forces the rest of the arguments to be
2185             # interpreted as a list, even if there is only one of them:
2186             #
2187             # exec { $args[0] } @args # safe even with one-argument list
2188             # or die "can't exec @args: $!";
2189              
2190             # P.855 exec
2191             # in Chapter 27: Functions
2192             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2193             #
2194             # As we mentioned earlier, exec treats a discrete list of arguments as a
2195             # directive to bypass shell processing. However, there is one place where
2196             # you might still get tripped up. The exec call (and system, too) cannot
2197             # distinguish between a single scalar argument and an array containing
2198             # only one element.
2199             #
2200             # @args = ("echo surprise"); # just one element in list
2201             # exec @args # still subject to shell escapes
2202             # || die "exec: $!"; # because @args == 1
2203             #
2204             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2205             # argument as the pathname, which forces the rest of the arguments to be
2206             # interpreted as a list, even if there is only one of them:
2207             #
2208             # exec { $args[0] } @args # safe even with one-argument list
2209             # || die "can't exec @args: $!";
2210              
2211 204         1649 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         422  
2212             }
2213              
2214             #
2215             # Latin-5 order to character (with parameter)
2216             #
2217             sub Elatin5::chr(;$) {
2218              
2219 204 0   0 0 16679204 my $c = @_ ? $_[0] : $_;
2220              
2221 0 0       0 if ($c == 0x00) {
2222 0         0 return "\x00";
2223             }
2224             else {
2225 0         0 my @chr = ();
2226 0         0 while ($c > 0) {
2227 0         0 unshift @chr, ($c % 0x100);
2228 0         0 $c = int($c / 0x100);
2229             }
2230 0         0 return pack 'C*', @chr;
2231             }
2232             }
2233              
2234             #
2235             # Latin-5 order to character (without parameter)
2236             #
2237             sub Elatin5::chr_() {
2238              
2239 0     0 0 0 my $c = $_;
2240              
2241 0 0       0 if ($c == 0x00) {
2242 0         0 return "\x00";
2243             }
2244             else {
2245 0         0 my @chr = ();
2246 0         0 while ($c > 0) {
2247 0         0 unshift @chr, ($c % 0x100);
2248 0         0 $c = int($c / 0x100);
2249             }
2250 0         0 return pack 'C*', @chr;
2251             }
2252             }
2253              
2254             #
2255             # Latin-5 path globbing (with parameter)
2256             #
2257             sub Elatin5::glob($) {
2258              
2259 0 0   0 0 0 if (wantarray) {
2260 0         0 my @glob = _DOS_like_glob(@_);
2261 0         0 for my $glob (@glob) {
2262 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2263             }
2264 0         0 return @glob;
2265             }
2266             else {
2267 0         0 my $glob = _DOS_like_glob(@_);
2268 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2269 0         0 return $glob;
2270             }
2271             }
2272              
2273             #
2274             # Latin-5 path globbing (without parameter)
2275             #
2276             sub Elatin5::glob_() {
2277              
2278 0 0   0 0 0 if (wantarray) {
2279 0         0 my @glob = _DOS_like_glob();
2280 0         0 for my $glob (@glob) {
2281 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2282             }
2283 0         0 return @glob;
2284             }
2285             else {
2286 0         0 my $glob = _DOS_like_glob();
2287 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2288 0         0 return $glob;
2289             }
2290             }
2291              
2292             #
2293             # Latin-5 path globbing via File::DosGlob 1.10
2294             #
2295             # Often I confuse "_dosglob" and "_doglob".
2296             # So, I renamed "_dosglob" to "_DOS_like_glob".
2297             #
2298             my %iter;
2299             my %entries;
2300             sub _DOS_like_glob {
2301              
2302             # context (keyed by second cxix argument provided by core)
2303 0     0   0 my($expr,$cxix) = @_;
2304              
2305             # glob without args defaults to $_
2306 0 0       0 $expr = $_ if not defined $expr;
2307              
2308             # represents the current user's home directory
2309             #
2310             # 7.3. Expanding Tildes in Filenames
2311             # in Chapter 7. File Access
2312             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2313             #
2314             # and File::HomeDir, File::HomeDir::Windows module
2315              
2316             # DOS-like system
2317 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2318 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2319             { my_home_MSWin32() }oxmse;
2320             }
2321              
2322             # UNIX-like system
2323 0 0 0     0 else {
  0         0  
2324             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2325             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2326             }
2327 0 0       0  
2328 0 0       0 # assume global context if not provided one
2329             $cxix = '_G_' if not defined $cxix;
2330             $iter{$cxix} = 0 if not exists $iter{$cxix};
2331 0 0       0  
2332 0         0 # if we're just beginning, do it all first
2333             if ($iter{$cxix} == 0) {
2334             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2335             }
2336 0 0       0  
2337 0         0 # chuck it all out, quick or slow
2338 0         0 if (wantarray) {
  0         0  
2339             delete $iter{$cxix};
2340             return @{delete $entries{$cxix}};
2341 0 0       0 }
  0         0  
2342 0         0 else {
  0         0  
2343             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2344             return shift @{$entries{$cxix}};
2345             }
2346 0         0 else {
2347 0         0 # return undef for EOL
2348 0         0 delete $iter{$cxix};
2349             delete $entries{$cxix};
2350             return undef;
2351             }
2352             }
2353             }
2354              
2355             #
2356             # Latin-5 path globbing subroutine
2357             #
2358 0     0   0 sub _do_glob {
2359 0         0  
2360 0         0 my($cond,@expr) = @_;
2361             my @glob = ();
2362             my $fix_drive_relative_paths = 0;
2363 0         0  
2364 0 0       0 OUTER:
2365 0 0       0 for my $expr (@expr) {
2366             next OUTER if not defined $expr;
2367 0         0 next OUTER if $expr eq '';
2368 0         0  
2369 0         0 my @matched = ();
2370 0         0 my @globdir = ();
2371 0         0 my $head = '.';
2372             my $pathsep = '/';
2373             my $tail;
2374 0 0       0  
2375 0         0 # if argument is within quotes strip em and do no globbing
2376 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2377 0 0       0 $expr = $1;
2378 0         0 if ($cond eq 'd') {
2379             if (-d $expr) {
2380             push @glob, $expr;
2381             }
2382 0 0       0 }
2383 0         0 else {
2384             if (-e $expr) {
2385             push @glob, $expr;
2386 0         0 }
2387             }
2388             next OUTER;
2389             }
2390              
2391 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2392 0 0       0 # to h:./*.pm to expand correctly
2393 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2394             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2395             $fix_drive_relative_paths = 1;
2396             }
2397 0 0       0 }
2398 0 0       0  
2399 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2400 0         0 if ($tail eq '') {
2401             push @glob, $expr;
2402 0 0       0 next OUTER;
2403 0 0       0 }
2404 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2405 0         0 if (@globdir = _do_glob('d', $head)) {
2406             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2407             next OUTER;
2408 0 0 0     0 }
2409 0         0 }
2410             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2411 0         0 $head .= $pathsep;
2412             }
2413             $expr = $tail;
2414             }
2415 0 0       0  
2416 0 0       0 # If file component has no wildcards, we can avoid opendir
2417 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2418             if ($head eq '.') {
2419 0 0 0     0 $head = '';
2420 0         0 }
2421             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2422 0         0 $head .= $pathsep;
2423 0 0       0 }
2424 0 0       0 $head .= $expr;
2425 0         0 if ($cond eq 'd') {
2426             if (-d $head) {
2427             push @glob, $head;
2428             }
2429 0 0       0 }
2430 0         0 else {
2431             if (-e $head) {
2432             push @glob, $head;
2433 0         0 }
2434             }
2435 0 0       0 next OUTER;
2436 0         0 }
2437 0         0 opendir(*DIR, $head) or next OUTER;
2438             my @leaf = readdir DIR;
2439 0 0       0 closedir DIR;
2440 0         0  
2441             if ($head eq '.') {
2442 0 0 0     0 $head = '';
2443 0         0 }
2444             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2445             $head .= $pathsep;
2446 0         0 }
2447 0         0  
2448 0         0 my $pattern = '';
2449             while ($expr =~ / \G ($q_char) /oxgc) {
2450             my $char = $1;
2451              
2452             # 6.9. Matching Shell Globs as Regular Expressions
2453             # in Chapter 6. Pattern Matching
2454             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2455 0 0       0 # (and so on)
    0          
    0          
2456 0         0  
2457             if ($char eq '*') {
2458             $pattern .= "(?:$your_char)*",
2459 0         0 }
2460             elsif ($char eq '?') {
2461             $pattern .= "(?:$your_char)?", # DOS style
2462             # $pattern .= "(?:$your_char)", # UNIX style
2463 0         0 }
2464             elsif ((my $fc = Elatin5::fc($char)) ne $char) {
2465             $pattern .= $fc;
2466 0         0 }
2467             else {
2468             $pattern .= quotemeta $char;
2469 0     0   0 }
  0         0  
2470             }
2471             my $matchsub = sub { Elatin5::fc($_[0]) =~ /\A $pattern \z/xms };
2472              
2473             # if ($@) {
2474             # print STDERR "$0: $@\n";
2475             # next OUTER;
2476             # }
2477 0         0  
2478 0 0 0     0 INNER:
2479 0         0 for my $leaf (@leaf) {
2480             if ($leaf eq '.' or $leaf eq '..') {
2481 0 0 0     0 next INNER;
2482 0         0 }
2483             if ($cond eq 'd' and not -d "$head$leaf") {
2484             next INNER;
2485 0 0       0 }
2486 0         0  
2487 0         0 if (&$matchsub($leaf)) {
2488             push @matched, "$head$leaf";
2489             next INNER;
2490             }
2491              
2492             # [DOS compatibility special case]
2493 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2494              
2495             if (Elatin5::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2496             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2497 0 0       0 Elatin5::index($pattern,'\\.') != -1 # pattern has a dot.
2498 0         0 ) {
2499 0         0 if (&$matchsub("$leaf.")) {
2500             push @matched, "$head$leaf";
2501             next INNER;
2502             }
2503 0 0       0 }
2504 0         0 }
2505             if (@matched) {
2506             push @glob, @matched;
2507 0 0       0 }
2508 0         0 }
2509 0         0 if ($fix_drive_relative_paths) {
2510             for my $glob (@glob) {
2511             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2512 0         0 }
2513             }
2514             return @glob;
2515             }
2516              
2517             #
2518             # Latin-5 parse line
2519             #
2520 0     0   0 sub _parse_line {
2521              
2522 0         0 my($line) = @_;
2523 0         0  
2524 0         0 $line .= ' ';
2525             my @piece = ();
2526             while ($line =~ /
2527             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2528             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2529 0 0       0 /oxmsg
2530             ) {
2531 0         0 push @piece, defined($1) ? $1 : $2;
2532             }
2533             return @piece;
2534             }
2535              
2536             #
2537             # Latin-5 parse path
2538             #
2539 0     0   0 sub _parse_path {
2540              
2541 0         0 my($path,$pathsep) = @_;
2542 0         0  
2543 0         0 $path .= '/';
2544             my @subpath = ();
2545             while ($path =~ /
2546             ((?: [^\/\\] )+?) [\/\\]
2547 0         0 /oxmsg
2548             ) {
2549             push @subpath, $1;
2550 0         0 }
2551 0         0  
2552 0         0 my $tail = pop @subpath;
2553             my $head = join $pathsep, @subpath;
2554             return $head, $tail;
2555             }
2556              
2557             #
2558             # via File::HomeDir::Windows 1.00
2559             #
2560             sub my_home_MSWin32 {
2561              
2562             # A lot of unix people and unix-derived tools rely on
2563 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2564 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2565             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2566             return $ENV{'HOME'};
2567             }
2568              
2569 0         0 # Do we have a user profile?
2570             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2571             return $ENV{'USERPROFILE'};
2572             }
2573              
2574 0         0 # Some Windows use something like $ENV{'HOME'}
2575             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2576             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2577 0         0 }
2578              
2579             return undef;
2580             }
2581              
2582             #
2583             # via File::HomeDir::Unix 1.00
2584 0     0 0 0 #
2585             sub my_home {
2586 0 0 0     0 my $home;
    0 0        
2587 0         0  
2588             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2589             $home = $ENV{'HOME'};
2590             }
2591              
2592             # This is from the original code, but I'm guessing
2593 0         0 # it means "login directory" and exists on some Unixes.
2594             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2595             $home = $ENV{'LOGDIR'};
2596             }
2597              
2598             ### More-desperate methods
2599              
2600 0         0 # Light desperation on any (Unixish) platform
2601             else {
2602             $home = CORE::eval q{ (getpwuid($<))[7] };
2603             }
2604              
2605 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2606 0         0 # For example, "nobody"-like users might use /nonexistant
2607             if (defined $home and ! -d($home)) {
2608 0         0 $home = undef;
2609             }
2610             return $home;
2611             }
2612              
2613             #
2614             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2615 0     0 0 0 #
2616             sub Elatin5::PREMATCH {
2617             return $`;
2618             }
2619              
2620             #
2621             # ${^MATCH}, $MATCH, $& the string that matched
2622 0     0 0 0 #
2623             sub Elatin5::MATCH {
2624             return $&;
2625             }
2626              
2627             #
2628             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2629 0     0 0 0 #
2630             sub Elatin5::POSTMATCH {
2631             return $';
2632             }
2633              
2634             #
2635             # Latin-5 character to order (with parameter)
2636             #
2637 0 0   0 1 0 sub Latin5::ord(;$) {
2638              
2639 0 0       0 local $_ = shift if @_;
2640 0         0  
2641 0         0 if (/\A ($q_char) /oxms) {
2642 0         0 my @ord = unpack 'C*', $1;
2643 0         0 my $ord = 0;
2644             while (my $o = shift @ord) {
2645 0         0 $ord = $ord * 0x100 + $o;
2646             }
2647             return $ord;
2648 0         0 }
2649             else {
2650             return CORE::ord $_;
2651             }
2652             }
2653              
2654             #
2655             # Latin-5 character to order (without parameter)
2656             #
2657 0 0   0 0 0 sub Latin5::ord_() {
2658 0         0  
2659 0         0 if (/\A ($q_char) /oxms) {
2660 0         0 my @ord = unpack 'C*', $1;
2661 0         0 my $ord = 0;
2662             while (my $o = shift @ord) {
2663 0         0 $ord = $ord * 0x100 + $o;
2664             }
2665             return $ord;
2666 0         0 }
2667             else {
2668             return CORE::ord $_;
2669             }
2670             }
2671              
2672             #
2673             # Latin-5 reverse
2674             #
2675 0 0   0 0 0 sub Latin5::reverse(@) {
2676 0         0  
2677             if (wantarray) {
2678             return CORE::reverse @_;
2679             }
2680             else {
2681              
2682             # One of us once cornered Larry in an elevator and asked him what
2683             # problem he was solving with this, but he looked as far off into
2684             # the distance as he could in an elevator and said, "It seemed like
2685 0         0 # a good idea at the time."
2686              
2687             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2688             }
2689             }
2690              
2691             #
2692             # Latin-5 getc (with parameter, without parameter)
2693             #
2694 0     0 0 0 sub Latin5::getc(;*@) {
2695 0 0       0  
2696 0 0 0     0 my($package) = caller;
2697             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2698 0         0 croak 'Too many arguments for Latin5::getc' if @_ and not wantarray;
  0         0  
2699 0         0  
2700 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2701 0         0 my $getc = '';
2702 0 0       0 for my $length ($length[0] .. $length[-1]) {
2703 0 0       0 $getc .= CORE::getc($fh);
2704 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2705             if ($getc =~ /\A ${Elatin5::dot_s} \z/oxms) {
2706             return wantarray ? ($getc,@_) : $getc;
2707             }
2708 0 0       0 }
2709             }
2710             return wantarray ? ($getc,@_) : $getc;
2711             }
2712              
2713             #
2714             # Latin-5 length by character
2715             #
2716 0 0   0 1 0 sub Latin5::length(;$) {
2717              
2718 0         0 local $_ = shift if @_;
2719 0         0  
2720             local @_ = /\G ($q_char) /oxmsg;
2721             return scalar @_;
2722             }
2723              
2724             #
2725             # Latin-5 substr by character
2726             #
2727             BEGIN {
2728              
2729             # P.232 The lvalue Attribute
2730             # in Chapter 6: Subroutines
2731             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2732              
2733             # P.336 The lvalue Attribute
2734             # in Chapter 7: Subroutines
2735             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2736              
2737             # P.144 8.4 Lvalue subroutines
2738             # in Chapter 8: perlsub: Perl subroutines
2739 204 50 0 204 1 119510 # 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  
2740              
2741             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2742             # vv----------------------*******
2743             sub Latin5::substr($$;$$) %s {
2744              
2745             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2746              
2747             # If the substring is beyond either end of the string, substr() returns the undefined
2748             # value and produces a warning. When used as an lvalue, specifying a substring that
2749             # is entirely outside the string raises an exception.
2750             # http://perldoc.perl.org/functions/substr.html
2751              
2752             # A return with no argument returns the scalar value undef in scalar context,
2753             # an empty list () in list context, and (naturally) nothing at all in void
2754             # context.
2755              
2756             my $offset = $_[1];
2757             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2758             return;
2759             }
2760              
2761             # substr($string,$offset,$length,$replacement)
2762             if (@_ == 4) {
2763             my(undef,undef,$length,$replacement) = @_;
2764             my $substr = join '', splice(@char, $offset, $length, $replacement);
2765             $_[0] = join '', @char;
2766              
2767             # return $substr; this doesn't work, don't say "return"
2768             $substr;
2769             }
2770              
2771             # substr($string,$offset,$length)
2772             elsif (@_ == 3) {
2773             my(undef,undef,$length) = @_;
2774             my $octet_offset = 0;
2775             my $octet_length = 0;
2776             if ($offset == 0) {
2777             $octet_offset = 0;
2778             }
2779             elsif ($offset > 0) {
2780             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2781             }
2782             else {
2783             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2784             }
2785             if ($length == 0) {
2786             $octet_length = 0;
2787             }
2788             elsif ($length > 0) {
2789             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2790             }
2791             else {
2792             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2793             }
2794             CORE::substr($_[0], $octet_offset, $octet_length);
2795             }
2796              
2797             # substr($string,$offset)
2798             else {
2799             my $octet_offset = 0;
2800             if ($offset == 0) {
2801             $octet_offset = 0;
2802             }
2803             elsif ($offset > 0) {
2804             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2805             }
2806             else {
2807             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset);
2810             }
2811             }
2812             END
2813             }
2814              
2815             #
2816             # Latin-5 index by character
2817             #
2818 0     0 1 0 sub Latin5::index($$;$) {
2819 0 0       0  
2820 0         0 my $index;
2821             if (@_ == 3) {
2822             $index = Elatin5::index($_[0], $_[1], CORE::length(Latin5::substr($_[0], 0, $_[2])));
2823 0         0 }
2824             else {
2825             $index = Elatin5::index($_[0], $_[1]);
2826 0 0       0 }
2827 0         0  
2828             if ($index == -1) {
2829             return -1;
2830 0         0 }
2831             else {
2832             return Latin5::length(CORE::substr $_[0], 0, $index);
2833             }
2834             }
2835              
2836             #
2837             # Latin-5 rindex by character
2838             #
2839 0     0 1 0 sub Latin5::rindex($$;$) {
2840 0 0       0  
2841 0         0 my $rindex;
2842             if (@_ == 3) {
2843             $rindex = Elatin5::rindex($_[0], $_[1], CORE::length(Latin5::substr($_[0], 0, $_[2])));
2844 0         0 }
2845             else {
2846             $rindex = Elatin5::rindex($_[0], $_[1]);
2847 0 0       0 }
2848 0         0  
2849             if ($rindex == -1) {
2850             return -1;
2851 0         0 }
2852             else {
2853             return Latin5::length(CORE::substr $_[0], 0, $rindex);
2854             }
2855             }
2856              
2857 204     204   1799 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         537  
  204         22082  
2858             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2859             use vars qw($slash); $slash = 'm//';
2860              
2861             # ord() to ord() or Latin5::ord()
2862             my $function_ord = 'ord';
2863              
2864             # ord to ord or Latin5::ord_
2865             my $function_ord_ = 'ord';
2866              
2867             # reverse to reverse or Latin5::reverse
2868             my $function_reverse = 'reverse';
2869              
2870             # getc to getc or Latin5::getc
2871             my $function_getc = 'getc';
2872              
2873             # P.1023 Appendix W.9 Multibyte Anchoring
2874             # of ISBN 1-56592-224-7 CJKV Information Processing
2875              
2876 204     204   1761 my $anchor = '';
  204     0   408  
  204         8853320  
2877              
2878             use vars qw($nest);
2879              
2880             # regexp of nested parens in qqXX
2881              
2882             # P.340 Matching Nested Constructs with Embedded Code
2883             # in Chapter 7: Perl
2884             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2885              
2886             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2887             [^\\()] |
2888             \( (?{$nest++}) |
2889             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2890             \\ [^c] |
2891             \\c[\x40-\x5F] |
2892             [\x00-\xFF]
2893             }xms;
2894              
2895             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2896             [^\\{}] |
2897             \{ (?{$nest++}) |
2898             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2899             \\ [^c] |
2900             \\c[\x40-\x5F] |
2901             [\x00-\xFF]
2902             }xms;
2903              
2904             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2905             [^\\\[\]] |
2906             \[ (?{$nest++}) |
2907             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2908             \\ [^c] |
2909             \\c[\x40-\x5F] |
2910             [\x00-\xFF]
2911             }xms;
2912              
2913             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2914             [^\\<>] |
2915             \< (?{$nest++}) |
2916             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2917             \\ [^c] |
2918             \\c[\x40-\x5F] |
2919             [\x00-\xFF]
2920             }xms;
2921              
2922             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2923             (?: ::)? (?:
2924             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2925             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2926             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2927             ))
2928             }xms;
2929              
2930             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2931             (?: ::)? (?:
2932             (?>[0-9]+) |
2933             [^a-zA-Z_0-9\[\]] |
2934             ^[A-Z] |
2935             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2936             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2937             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2938             ))
2939             }xms;
2940              
2941             my $qq_substr = qr{(?> Char::substr | Latin5::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2942             }xms;
2943              
2944             # regexp of nested parens in qXX
2945             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2946             [^()] |
2947             \( (?{$nest++}) |
2948             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2949             [\x00-\xFF]
2950             }xms;
2951              
2952             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2953             [^\{\}] |
2954             \{ (?{$nest++}) |
2955             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2956             [\x00-\xFF]
2957             }xms;
2958              
2959             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2960             [^\[\]] |
2961             \[ (?{$nest++}) |
2962             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2963             [\x00-\xFF]
2964             }xms;
2965              
2966             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2967             [^<>] |
2968             \< (?{$nest++}) |
2969             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2970             [\x00-\xFF]
2971             }xms;
2972              
2973             my $matched = '';
2974             my $s_matched = '';
2975              
2976             my $tr_variable = ''; # variable of tr///
2977             my $sub_variable = ''; # variable of s///
2978             my $bind_operator = ''; # =~ or !~
2979              
2980             my @heredoc = (); # here document
2981             my @heredoc_delimiter = ();
2982             my $here_script = ''; # here script
2983              
2984             #
2985             # escape Latin-5 script
2986 0 50   204 0 0 #
2987             sub Latin5::escape(;$) {
2988             local($_) = $_[0] if @_;
2989              
2990             # P.359 The Study Function
2991             # in Chapter 7: Perl
2992 204         612 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2993              
2994             study $_; # Yes, I studied study yesterday.
2995              
2996             # while all script
2997              
2998             # 6.14. Matching from Where the Last Pattern Left Off
2999             # in Chapter 6. Pattern Matching
3000             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3001             # (and so on)
3002              
3003             # one member of Tag-team
3004             #
3005             # P.128 Start of match (or end of previous match): \G
3006             # P.130 Advanced Use of \G with Perl
3007             # in Chapter 3: Overview of Regular Expression Features and Flavors
3008             # P.255 Use leading anchors
3009             # P.256 Expose ^ and \G at the front expressions
3010             # in Chapter 6: Crafting an Efficient Expression
3011             # P.315 "Tag-team" matching with /gc
3012             # in Chapter 7: Perl
3013 204         443 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3014 204         378  
3015 204         780 my $e_script = '';
3016             while (not /\G \z/oxgc) { # member
3017             $e_script .= Latin5::escape_token();
3018 74693         111381 }
3019              
3020             return $e_script;
3021             }
3022              
3023             #
3024             # escape Latin-5 token of script
3025             #
3026             sub Latin5::escape_token {
3027              
3028 204     74693 0 2856 # \n output here document
3029              
3030             my $ignore_modules = join('|', qw(
3031             utf8
3032             bytes
3033             charnames
3034             I18N::Japanese
3035             I18N::Collate
3036             I18N::JExt
3037             File::DosGlob
3038             Wild
3039             Wildcard
3040             Japanese
3041             ));
3042              
3043             # another member of Tag-team
3044             #
3045             # P.315 "Tag-team" matching with /gc
3046             # in Chapter 7: Perl
3047 74693 100 100     87361 # 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          
3048 74693         2838212  
3049 12514 100       15389 if (/\G ( \n ) /oxgc) { # another member (and so on)
3050 12514         21330 my $heredoc = '';
3051             if (scalar(@heredoc_delimiter) >= 1) {
3052 174         254 $slash = 'm//';
3053 174         355  
3054             $heredoc = join '', @heredoc;
3055             @heredoc = ();
3056 174         326  
3057 174         322 # skip here document
3058             for my $heredoc_delimiter (@heredoc_delimiter) {
3059 174         1087 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3060             }
3061 174         313 @heredoc_delimiter = ();
3062              
3063 174         246 $here_script = '';
3064             }
3065             return "\n" . $heredoc;
3066             }
3067 12514         37448  
3068             # ignore space, comment
3069             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3070              
3071             # if (, elsif (, unless (, while (, until (, given (, and when (
3072              
3073             # given, when
3074              
3075             # P.225 The given Statement
3076             # in Chapter 15: Smart Matching and given-when
3077             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3078              
3079             # P.133 The given Statement
3080             # in Chapter 4: Statements and Declarations
3081             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3082 17886         53634  
3083 1401         2253 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3084             $slash = 'm//';
3085             return $1;
3086             }
3087              
3088             # scalar variable ($scalar = ...) =~ tr///;
3089             # scalar variable ($scalar = ...) =~ s///;
3090              
3091             # state
3092              
3093             # P.68 Persistent, Private Variables
3094             # in Chapter 4: Subroutines
3095             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3096              
3097             # P.160 Persistent Lexically Scoped Variables: state
3098             # in Chapter 4: Statements and Declarations
3099             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3100              
3101             # (and so on)
3102 1401         4066  
3103             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3104 86 50       185 my $e_string = e_string($1);
    50          
3105 86         1952  
3106 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3107 0         0 $tr_variable = $e_string . e_string($1);
3108 0         0 $bind_operator = $2;
3109             $slash = 'm//';
3110             return '';
3111 0         0 }
3112 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3113 0         0 $sub_variable = $e_string . e_string($1);
3114 0         0 $bind_operator = $2;
3115             $slash = 'm//';
3116             return '';
3117 0         0 }
3118 86         168 else {
3119             $slash = 'div';
3120             return $e_string;
3121             }
3122             }
3123              
3124 86         310 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
3125 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3126             $slash = 'div';
3127             return q{Elatin5::PREMATCH()};
3128             }
3129              
3130 4         15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
3131 28         51 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3132             $slash = 'div';
3133             return q{Elatin5::MATCH()};
3134             }
3135              
3136 28         84 # $', ${'} --> $', ${'}
3137 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3138             $slash = 'div';
3139             return $1;
3140             }
3141              
3142 1         5 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
3143 3         7 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3144             $slash = 'div';
3145             return q{Elatin5::POSTMATCH()};
3146             }
3147              
3148             # scalar variable $scalar =~ tr///;
3149             # scalar variable $scalar =~ s///;
3150             # substr() =~ tr///;
3151 3         10 # substr() =~ s///;
3152             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3153 1671 100       3585 my $scalar = e_string($1);
    100          
3154 1671         7226  
3155 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3156 1         4 $tr_variable = $scalar;
3157 1         1 $bind_operator = $1;
3158             $slash = 'm//';
3159             return '';
3160 1         4 }
3161 61         133 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3162 61         131 $sub_variable = $scalar;
3163 61         129 $bind_operator = $1;
3164             $slash = 'm//';
3165             return '';
3166 61         189 }
3167 1609         2558 else {
3168             $slash = 'div';
3169             return $scalar;
3170             }
3171             }
3172              
3173 1609         4153 # end of statement
3174             elsif (/\G ( [,;] ) /oxgc) {
3175             $slash = 'm//';
3176 4976         7255  
3177             # clear tr/// variable
3178             $tr_variable = '';
3179 4976         5747  
3180             # clear s/// variable
3181 4976         5509 $sub_variable = '';
3182              
3183 4976         6538 $bind_operator = '';
3184              
3185             return $1;
3186             }
3187              
3188 4976         16089 # bareword
3189             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3190             return $1;
3191             }
3192              
3193 0         0 # $0 --> $0
3194 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3195             $slash = 'div';
3196             return $1;
3197 2         8 }
3198 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3199             $slash = 'div';
3200             return $1;
3201             }
3202              
3203 0         0 # $$ --> $$
3204 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3205             $slash = 'div';
3206             return $1;
3207             }
3208              
3209             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3210 1         3 # $1, $2, $3 --> $1, $2, $3 otherwise
3211 4         7 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3212             $slash = 'div';
3213             return e_capture($1);
3214 4         8 }
3215 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3216             $slash = 'div';
3217             return e_capture($1);
3218             }
3219              
3220 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3221 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3222             $slash = 'div';
3223             return e_capture($1.'->'.$2);
3224             }
3225              
3226 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3227 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3228             $slash = 'div';
3229             return e_capture($1.'->'.$2);
3230             }
3231              
3232 0         0 # $$foo
3233 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3234             $slash = 'div';
3235             return e_capture($1);
3236             }
3237              
3238 0         0 # ${ foo }
3239 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3240             $slash = 'div';
3241             return '${' . $1 . '}';
3242             }
3243              
3244 0         0 # ${ ... }
3245 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3246             $slash = 'div';
3247             return e_capture($1);
3248             }
3249              
3250             # variable or function
3251 0         0 # $ @ % & * $ #
3252 42         72 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) {
3253             $slash = 'div';
3254             return $1;
3255             }
3256             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3257 42         141 # $ @ # \ ' " / ? ( ) [ ] < >
3258 62         110 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3259             $slash = 'div';
3260             return $1;
3261             }
3262              
3263 62         196 # while ()
3264             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3265             return $1;
3266             }
3267              
3268             # while () --- glob
3269              
3270             # avoid "Error: Runtime exception" of perl version 5.005_03
3271 0         0  
3272             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3273             return 'while ($_ = Elatin5::glob("' . $1 . '"))';
3274             }
3275              
3276 0         0 # while (glob)
3277             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3278             return 'while ($_ = Elatin5::glob_)';
3279             }
3280              
3281 0         0 # while (glob(WILDCARD))
3282             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3283             return 'while ($_ = Elatin5::glob';
3284             }
3285 0         0  
  248         654  
3286             # doit if, doit unless, doit while, doit until, doit for, doit when
3287             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3288 248         874  
  19         35  
3289 19         65 # subroutines of package Elatin5
  0         0  
3290 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         22  
3291 13         30 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3292 0         0 elsif (/\G \b Latin5::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         179  
3293 114         340 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         3  
3294 2         7 elsif (/\G \b Latin5::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin5::escape'; }
  0         0  
3295 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         3  
3296 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::chop'; }
  0         0  
3297 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3298 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3299 0         0 elsif (/\G \b Latin5::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin5::index'; }
  2         4  
3300 2         7 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::index'; }
  0         0  
3301 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3302 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3303 0         0 elsif (/\G \b Latin5::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin5::rindex'; }
  1         3  
3304 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::rindex'; }
  0         0  
3305 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::lc'; }
  1         2  
3306 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::lcfirst'; }
  0         0  
3307 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::uc'; }
  6         11  
3308             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::ucfirst'; }
3309             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::fc'; }
3310 6         16  
  0         0  
3311 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3312 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3313 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3314 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3315 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3316 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3317             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3318 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  
3319 0         0  
  0         0  
3320 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3321 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3322 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3323 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3324 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3325             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3326             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3327 0         0  
  0         0  
3328 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3329 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3330 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3331             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3332 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3333 2         6  
  2         4  
3334 2         5 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         67  
3335 36         110 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3336 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::chr'; }
  8         14  
3337 8         23 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3338 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3339 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::glob'; }
  0         0  
3340 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::lc_'; }
  0         0  
3341 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::lcfirst_'; }
  0         0  
3342 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::uc_'; }
  0         0  
3343 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::ucfirst_'; }
  0         0  
3344             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::fc_'; }
3345 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3346 0         0  
  0         0  
3347 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3348 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3349 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::chr_'; }
  0         0  
3350 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3351 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3352 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::glob_'; }
  8         20  
3353             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3354             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3355 8         30 # split
3356             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3357 87         179 $slash = 'm//';
3358 87         131  
3359 87         302 my $e = '';
3360             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3361             $e .= $1;
3362             }
3363 85 100       305  
  87 100       5409  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3364             # end of split
3365             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin5::split' . $e; }
3366 2         9  
3367             # split scalar value
3368             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin5::split' . $e . e_string($1); }
3369 1         6  
3370 0         0 # split literal space
3371 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin5::split' . $e . qq {qq$1 $2}; }
3372 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3373 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3374 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3375 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3376 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3377 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin5::split' . $e . qq {q$1 $2}; }
3378 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3379 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3380 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3381 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3382 10         42 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3383             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin5::split' . $e . qq {' '}; }
3384             elsif (/\G " [ ] " /oxgc) { return 'Elatin5::split' . $e . qq {" "}; }
3385              
3386 0 0       0 # split qq//
  0         0  
3387             elsif (/\G \b (qq) \b /oxgc) {
3388 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3389 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3390 0         0 while (not /\G \z/oxgc) {
3391 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3392 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3393 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3394 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3395 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3396             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3397 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3398             }
3399             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3400             }
3401             }
3402              
3403 0 50       0 # split qr//
  12         407  
3404             elsif (/\G \b (qr) \b /oxgc) {
3405 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3406 12 50       63 else {
  12 50       3001  
    50          
    50          
    50          
    50          
    50          
    50          
3407 0         0 while (not /\G \z/oxgc) {
3408 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3409 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3410 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3411 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3412 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3413 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3414             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3415 12         93 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3416             }
3417             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3418             }
3419             }
3420              
3421 0 0       0 # split q//
  0         0  
3422             elsif (/\G \b (q) \b /oxgc) {
3423 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3424 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3425 0         0 while (not /\G \z/oxgc) {
3426 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3427 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3428 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3429 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3430 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3431             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3432 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3433             }
3434             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3435             }
3436             }
3437              
3438 0 50       0 # split m//
  18         471  
3439             elsif (/\G \b (m) \b /oxgc) {
3440 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3441 18 50       81 else {
  18 50       3870  
    50          
    50          
    50          
    50          
    50          
    50          
3442 0         0 while (not /\G \z/oxgc) {
3443 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3444 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3445 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3446 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3447 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3448 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3449             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3450 18         105 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3451             }
3452             die __FILE__, ": Search pattern not terminated\n";
3453             }
3454             }
3455              
3456 0         0 # split ''
3457 0         0 elsif (/\G (\') /oxgc) {
3458 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3459 0         0 while (not /\G \z/oxgc) {
3460 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3461 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3462             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3463 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3464             }
3465             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3466             }
3467              
3468 0         0 # split ""
3469 0         0 elsif (/\G (\") /oxgc) {
3470 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3471 0         0 while (not /\G \z/oxgc) {
3472 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3473 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3474             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3475 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3476             }
3477             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3478             }
3479              
3480 0         0 # split //
3481 44         116 elsif (/\G (\/) /oxgc) {
3482 44 50       149 my $regexp = '';
  381 50       1516  
    100          
    50          
3483 0         0 while (not /\G \z/oxgc) {
3484 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3485 44         174 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3486             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3487 337         754 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3488             }
3489             die __FILE__, ": Search pattern not terminated\n";
3490             }
3491             }
3492              
3493             # tr/// or y///
3494              
3495             # about [cdsrbB]* (/B modifier)
3496             #
3497             # P.559 appendix C
3498             # of ISBN 4-89052-384-7 Programming perl
3499             # (Japanese title is: Perl puroguramingu)
3500 0         0  
3501             elsif (/\G \b ( tr | y ) \b /oxgc) {
3502             my $ope = $1;
3503 3 50       8  
3504 3         48 # $1 $2 $3 $4 $5 $6
3505 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3506             my @tr = ($tr_variable,$2);
3507             return e_tr(@tr,'',$4,$6);
3508 0         0 }
3509 3         7 else {
3510 3 50       12 my $e = '';
  3 50       404  
    50          
    50          
    50          
    50          
3511             while (not /\G \z/oxgc) {
3512 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3513 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3514 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3515 0         0 while (not /\G \z/oxgc) {
3516 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3517 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3518 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3519 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3520             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3521 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3522             }
3523             die __FILE__, ": Transliteration replacement not terminated\n";
3524 0         0 }
3525 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3526 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3527 0         0 while (not /\G \z/oxgc) {
3528 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3529 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3530 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3531 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3532             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3533 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3534             }
3535             die __FILE__, ": Transliteration replacement not terminated\n";
3536 0         0 }
3537 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3538 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3539 0         0 while (not /\G \z/oxgc) {
3540 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3541 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3542 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3543 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3544             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3545 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3546             }
3547             die __FILE__, ": Transliteration replacement not terminated\n";
3548 0         0 }
3549 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3550 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3551 0         0 while (not /\G \z/oxgc) {
3552 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3553 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3554 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3555 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3556             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3557 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3558             }
3559             die __FILE__, ": Transliteration replacement not terminated\n";
3560             }
3561 0         0 # $1 $2 $3 $4 $5 $6
3562 3         15 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3563             my @tr = ($tr_variable,$2);
3564             return e_tr(@tr,'',$4,$6);
3565 3         14 }
3566             }
3567             die __FILE__, ": Transliteration pattern not terminated\n";
3568             }
3569             }
3570              
3571 0         0 # qq//
3572             elsif (/\G \b (qq) \b /oxgc) {
3573             my $ope = $1;
3574 2180 50       4814  
3575 2180         3938 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3576 0         0 if (/\G (\#) /oxgc) { # qq# #
3577 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3578 0         0 while (not /\G \z/oxgc) {
3579 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3580 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3581             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3582 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3583             }
3584             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3585             }
3586 0         0  
3587 2180         3034 else {
3588 2180 50       5232 my $e = '';
  2180 50       9078  
    100          
    50          
    50          
    0          
3589             while (not /\G \z/oxgc) {
3590             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3591              
3592 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3593 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3594 0         0 my $qq_string = '';
3595 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3596 0         0 while (not /\G \z/oxgc) {
3597 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3598             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3599 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3600 0         0 elsif (/\G (\)) /oxgc) {
3601             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3602 0         0 else { $qq_string .= $1; }
3603             }
3604 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3605             }
3606             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3607             }
3608              
3609 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3610 2150         2958 elsif (/\G (\{) /oxgc) { # qq { }
3611 2150         3057 my $qq_string = '';
3612 2150 100       4550 local $nest = 1;
  84006 50       255585  
    100          
    100          
    50          
3613 722         1364 while (not /\G \z/oxgc) {
3614 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1553  
3615             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3616 1153 100       1955 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5021  
3617 2150         4233 elsif (/\G (\}) /oxgc) {
3618             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3619 1153         2337 else { $qq_string .= $1; }
3620             }
3621 78828         155038 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3622             }
3623             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3624             }
3625              
3626 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3627 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3628 0         0 my $qq_string = '';
3629 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3630 0         0 while (not /\G \z/oxgc) {
3631 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3632             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3633 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3634 0         0 elsif (/\G (\]) /oxgc) {
3635             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3636 0         0 else { $qq_string .= $1; }
3637             }
3638 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3639             }
3640             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3641             }
3642              
3643 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3644 30         54 elsif (/\G (\<) /oxgc) { # qq < >
3645 30         45 my $qq_string = '';
3646 30 100       100 local $nest = 1;
  1166 50       3917  
    50          
    100          
    50          
3647 22         51 while (not /\G \z/oxgc) {
3648 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3649             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3650 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         76  
3651 30         79 elsif (/\G (\>) /oxgc) {
3652             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3653 0         0 else { $qq_string .= $1; }
3654             }
3655 1114         2594 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3656             }
3657             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3658             }
3659              
3660 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3661 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3662 0         0 my $delimiter = $1;
3663 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3664 0         0 while (not /\G \z/oxgc) {
3665 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3666 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3667             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3668 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3669             }
3670             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3671 0         0 }
3672             }
3673             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3674             }
3675             }
3676              
3677 0         0 # qr//
3678 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3679 0         0 my $ope = $1;
3680             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3681             return e_qr($ope,$1,$3,$2,$4);
3682 0         0 }
3683 0         0 else {
3684 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3685 0         0 while (not /\G \z/oxgc) {
3686 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3687 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3688 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3689 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3690 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3691 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3692             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3693 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3694             }
3695             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3696             }
3697             }
3698              
3699 0         0 # qw//
3700 16 50       47 elsif (/\G \b (qw) \b /oxgc) {
3701 16         51 my $ope = $1;
3702             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3703             return e_qw($ope,$1,$3,$2);
3704 0         0 }
3705 16         38 else {
3706 16 50       55 my $e = '';
  16 50       133  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3707             while (not /\G \z/oxgc) {
3708 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3709 16         72  
3710             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3711 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3712 0         0  
3713             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3714 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3715 0         0  
3716             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3717 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3718 0         0  
3719             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3720 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3721 0         0  
3722             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3723 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3724             }
3725             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3726             }
3727             }
3728              
3729 0         0 # qx//
3730 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3731 0         0 my $ope = $1;
3732             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3733             return e_qq($ope,$1,$3,$2);
3734 0         0 }
3735 0         0 else {
3736 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3737 0         0 while (not /\G \z/oxgc) {
3738 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3739 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3740 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3741 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3742 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3743             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3744 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3745             }
3746             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3747             }
3748             }
3749              
3750 0         0 # q//
3751             elsif (/\G \b (q) \b /oxgc) {
3752             my $ope = $1;
3753              
3754             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3755              
3756             # avoid "Error: Runtime exception" of perl version 5.005_03
3757 410 50       996 # (and so on)
3758 410         952  
3759 0         0 if (/\G (\#) /oxgc) { # q# #
3760 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3761 0         0 while (not /\G \z/oxgc) {
3762 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3763 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3764             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3765 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3766             }
3767             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3768             }
3769 0         0  
3770 410         678 else {
3771 410 50       1154 my $e = '';
  410 50       1991  
    100          
    50          
    100          
    50          
3772             while (not /\G \z/oxgc) {
3773             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3774              
3775 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3776 0         0 elsif (/\G (\() /oxgc) { # q ( )
3777 0         0 my $q_string = '';
3778 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3779 0         0 while (not /\G \z/oxgc) {
3780 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3781 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3782             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3783 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3784 0         0 elsif (/\G (\)) /oxgc) {
3785             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3786 0         0 else { $q_string .= $1; }
3787             }
3788 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3789             }
3790             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3791             }
3792              
3793 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3794 404         827 elsif (/\G (\{) /oxgc) { # q { }
3795 404         631 my $q_string = '';
3796 404 50       1021 local $nest = 1;
  6770 50       24589  
    50          
    100          
    100          
    50          
3797 0         0 while (not /\G \z/oxgc) {
3798 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3799 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         153  
3800             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3801 107 100       191 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1017  
3802 404         989 elsif (/\G (\}) /oxgc) {
3803             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3804 107         208 else { $q_string .= $1; }
3805             }
3806 6152         11242 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3807             }
3808             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3809             }
3810              
3811 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3812 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3813 0         0 my $q_string = '';
3814 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3815 0         0 while (not /\G \z/oxgc) {
3816 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3817 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3818             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3819 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3820 0         0 elsif (/\G (\]) /oxgc) {
3821             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3822 0         0 else { $q_string .= $1; }
3823             }
3824 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3825             }
3826             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3827             }
3828              
3829 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3830 5         11 elsif (/\G (\<) /oxgc) { # q < >
3831 5         11 my $q_string = '';
3832 5 50       15 local $nest = 1;
  88 50       358  
    50          
    50          
    100          
    50          
3833 0         0 while (not /\G \z/oxgc) {
3834 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3835 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3836             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3837 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         13  
3838 5         12 elsif (/\G (\>) /oxgc) {
3839             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3840 0         0 else { $q_string .= $1; }
3841             }
3842 83         158 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3843             }
3844             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3845             }
3846              
3847 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3848 1         2 elsif (/\G (\S) /oxgc) { # q * *
3849 1         2 my $delimiter = $1;
3850 1 50       2 my $q_string = '';
  14 50       60  
    100          
    50          
3851 0         0 while (not /\G \z/oxgc) {
3852 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3853 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3854             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3855 13         28 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3856             }
3857             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3858 0         0 }
3859             }
3860             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3861             }
3862             }
3863              
3864 0         0 # m//
3865 209 50       619 elsif (/\G \b (m) \b /oxgc) {
3866 209         1360 my $ope = $1;
3867             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3868             return e_qr($ope,$1,$3,$2,$4);
3869 0         0 }
3870 209         330 else {
3871 209 50       536 my $e = '';
  209 50       10273  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3872 0         0 while (not /\G \z/oxgc) {
3873 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3874 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3875 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3876 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3877 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3878 10         88 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3879 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3880             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3881 199         631 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3882             }
3883             die __FILE__, ": Search pattern not terminated\n";
3884             }
3885             }
3886              
3887             # s///
3888              
3889             # about [cegimosxpradlunbB]* (/cg modifier)
3890             #
3891             # P.67 Pattern-Matching Operators
3892             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3893 0         0  
3894             elsif (/\G \b (s) \b /oxgc) {
3895             my $ope = $1;
3896 97 100       272  
3897 97         1627 # $1 $2 $3 $4 $5 $6
3898             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3899             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3900 1         5 }
3901 96         192 else {
3902 96 50       320 my $e = '';
  96 50       23889  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3903             while (not /\G \z/oxgc) {
3904 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3905 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3906 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3907             while (not /\G \z/oxgc) {
3908 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3909 0         0 # $1 $2 $3 $4
3910 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3911 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3916 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3917             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3918 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3919             }
3920             die __FILE__, ": Substitution replacement not terminated\n";
3921 0         0 }
3922 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3923 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3924             while (not /\G \z/oxgc) {
3925 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3926 0         0 # $1 $2 $3 $4
3927 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936             }
3937             die __FILE__, ": Substitution replacement not terminated\n";
3938 0         0 }
3939 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3940 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3941             while (not /\G \z/oxgc) {
3942 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3943 0         0 # $1 $2 $3 $4
3944 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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_angle)*?) (\>) /oxgc) {
3955 0 0       0 my @s = ($1,$2,$3);
  0 0       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 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968             }
3969             die __FILE__, ": Substitution replacement not terminated\n";
3970             }
3971 0         0 # $1 $2 $3 $4 $5 $6
3972             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3973             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3974             }
3975 21         81 # $1 $2 $3 $4 $5 $6
3976             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3977             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3978             }
3979 0         0 # $1 $2 $3 $4 $5 $6
3980             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3981             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3982             }
3983 0         0 # $1 $2 $3 $4 $5 $6
3984             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3985             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3986 75         349 }
3987             }
3988             die __FILE__, ": Substitution pattern not terminated\n";
3989             }
3990             }
3991 0         0  
3992 0         0 # require ignore module
3993 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3994             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3995             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3996 0         0  
3997 37         385 # use strict; --> use strict; no strict qw(refs);
3998 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3999             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4000             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4001              
4002 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4003 2         24 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4004             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4005             return "use $1; no strict qw(refs);";
4006 0         0 }
4007             else {
4008             return "use $1;";
4009             }
4010 2 0 0     12 }
      0        
4011 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4012             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4013             return "use $1; no strict qw(refs);";
4014 0         0 }
4015             else {
4016             return "use $1;";
4017             }
4018             }
4019 0         0  
4020 2         16 # ignore use module
4021 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4022             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4023             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4024 0         0  
4025 0         0 # ignore no module
4026 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4027             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4028             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4029 0         0  
4030             # use else
4031             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4032 0         0  
4033             # use else
4034             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4035              
4036 2         7 # ''
4037 848         1780 elsif (/\G (?
4038 848 100       2119 my $q_string = '';
  8254 100       24358  
    100          
    50          
4039 4         9 while (not /\G \z/oxgc) {
4040 48         85 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4041 848         1852 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4042             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4043 7354         14266 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4044             }
4045             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4046             }
4047              
4048 0         0 # ""
4049 1760         3282 elsif (/\G (\") /oxgc) {
4050 1760 100       4336 my $qq_string = '';
  34969 100       96703  
    100          
    50          
4051 67         151 while (not /\G \z/oxgc) {
4052 12         31 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4053 1760         3813 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4054             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4055 33130         63259 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4056             }
4057             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4058             }
4059              
4060 0         0 # ``
4061 1         3 elsif (/\G (\`) /oxgc) {
4062 1 50       5 my $qx_string = '';
  19 50       72  
    100          
    50          
4063 0         0 while (not /\G \z/oxgc) {
4064 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4065 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4066             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4067 18         29 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4068             }
4069             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4070             }
4071              
4072 0         0 # // --- not divide operator (num / num), not defined-or
4073 453         1415 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4074 453 50       1212 my $regexp = '';
  4496 50       14333  
    100          
    50          
4075 0         0 while (not /\G \z/oxgc) {
4076 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4077 453         1517 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4078             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4079 4043         7917 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4080             }
4081             die __FILE__, ": Search pattern not terminated\n";
4082             }
4083              
4084 0         0 # ?? --- not conditional operator (condition ? then : else)
4085 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4086 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4087 0         0 while (not /\G \z/oxgc) {
4088 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4089 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4090             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4091 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4092             }
4093             die __FILE__, ": Search pattern not terminated\n";
4094             }
4095 0         0  
  0         0  
4096             # <<>> (a safer ARGV)
4097             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4098 0         0  
  0         0  
4099             # << (bit shift) --- not here document
4100             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4101              
4102 0         0 # <<~'HEREDOC'
4103 6         18 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4104 6         17 $slash = 'm//';
4105             my $here_quote = $1;
4106             my $delimiter = $2;
4107 6 50       11  
4108 6         16 # get here document
4109 6         39 if ($here_script eq '') {
4110             $here_script = CORE::substr $_, pos $_;
4111 6 50       39 $here_script =~ s/.*?\n//oxm;
4112 6         77 }
4113 6         18 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4114 6         9 my $heredoc = $1;
4115 6         63 my $indent = $2;
4116 6         23 $heredoc =~ s{^$indent}{}msg; # no /ox
4117             push @heredoc, $heredoc . qq{\n$delimiter\n};
4118             push @heredoc_delimiter, qq{\\s*$delimiter};
4119 6         15 }
4120             else {
4121 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4122             }
4123             return qq{<<'$delimiter'};
4124             }
4125              
4126             # <<~\HEREDOC
4127              
4128             # P.66 2.6.6. "Here" Documents
4129             # in Chapter 2: Bits and Pieces
4130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4131              
4132             # P.73 "Here" Documents
4133             # in Chapter 2: Bits and Pieces
4134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4135 6         26  
4136 3         10 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4137 3         8 $slash = 'm//';
4138             my $here_quote = $1;
4139             my $delimiter = $2;
4140 3 50       7  
4141 3         10 # get here document
4142 3         165 if ($here_script eq '') {
4143             $here_script = CORE::substr $_, pos $_;
4144 3 50       26 $here_script =~ s/.*?\n//oxm;
4145 3         49 }
4146 3         10 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4147 3         6 my $heredoc = $1;
4148 3         53 my $indent = $2;
4149 3         13 $heredoc =~ s{^$indent}{}msg; # no /ox
4150             push @heredoc, $heredoc . qq{\n$delimiter\n};
4151             push @heredoc_delimiter, qq{\\s*$delimiter};
4152 3         10 }
4153             else {
4154 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4155             }
4156             return qq{<<\\$delimiter};
4157             }
4158              
4159 3         15 # <<~"HEREDOC"
4160 6         11 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4161 6         12 $slash = 'm//';
4162             my $here_quote = $1;
4163             my $delimiter = $2;
4164 6 50       9  
4165 6         11 # get here document
4166 6         35 if ($here_script eq '') {
4167             $here_script = CORE::substr $_, pos $_;
4168 6 50       30 $here_script =~ s/.*?\n//oxm;
4169 6         54 }
4170 6         11 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4171 6         10 my $heredoc = $1;
4172 6         41 my $indent = $2;
4173 6         15 $heredoc =~ s{^$indent}{}msg; # no /ox
4174             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4175             push @heredoc_delimiter, qq{\\s*$delimiter};
4176 6         12 }
4177             else {
4178 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4179             }
4180             return qq{<<"$delimiter"};
4181             }
4182              
4183 6         22 # <<~HEREDOC
4184 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4185 3         7 $slash = 'm//';
4186             my $here_quote = $1;
4187             my $delimiter = $2;
4188 3 50       5  
4189 3         9 # get here document
4190 3         20 if ($here_script eq '') {
4191             $here_script = CORE::substr $_, pos $_;
4192 3 50       18 $here_script =~ s/.*?\n//oxm;
4193 3         42 }
4194 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4195 3         5 my $heredoc = $1;
4196 3         33 my $indent = $2;
4197 3         8 $heredoc =~ s{^$indent}{}msg; # no /ox
4198             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4199             push @heredoc_delimiter, qq{\\s*$delimiter};
4200 3         8 }
4201             else {
4202 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4203             }
4204             return qq{<<$delimiter};
4205             }
4206              
4207 3         12 # <<~`HEREDOC`
4208 6         15 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4209 6         14 $slash = 'm//';
4210             my $here_quote = $1;
4211             my $delimiter = $2;
4212 6 50       10  
4213 6         62 # get here document
4214 6         36 if ($here_script eq '') {
4215             $here_script = CORE::substr $_, pos $_;
4216 6 50       42 $here_script =~ s/.*?\n//oxm;
4217 6         85 }
4218 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4219 6         11 my $heredoc = $1;
4220 6         70 my $indent = $2;
4221 6         24 $heredoc =~ s{^$indent}{}msg; # no /ox
4222             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4223             push @heredoc_delimiter, qq{\\s*$delimiter};
4224 6         16 }
4225             else {
4226 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4227             }
4228             return qq{<<`$delimiter`};
4229             }
4230              
4231 6         24 # <<'HEREDOC'
4232 72         148 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4233 72         152 $slash = 'm//';
4234             my $here_quote = $1;
4235             my $delimiter = $2;
4236 72 50       126  
4237 72         150 # get here document
4238 72         370 if ($here_script eq '') {
4239             $here_script = CORE::substr $_, pos $_;
4240 72 50       401 $here_script =~ s/.*?\n//oxm;
4241 72         578 }
4242 72         249 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4243             push @heredoc, $1 . qq{\n$delimiter\n};
4244             push @heredoc_delimiter, $delimiter;
4245 72         121 }
4246             else {
4247 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4248             }
4249             return $here_quote;
4250             }
4251              
4252             # <<\HEREDOC
4253              
4254             # P.66 2.6.6. "Here" Documents
4255             # in Chapter 2: Bits and Pieces
4256             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4257              
4258             # P.73 "Here" Documents
4259             # in Chapter 2: Bits and Pieces
4260             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4261 72         296  
4262 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4263 0         0 $slash = 'm//';
4264             my $here_quote = $1;
4265             my $delimiter = $2;
4266 0 0       0  
4267 0         0 # get here document
4268 0         0 if ($here_script eq '') {
4269             $here_script = CORE::substr $_, pos $_;
4270 0 0       0 $here_script =~ s/.*?\n//oxm;
4271 0         0 }
4272 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4273             push @heredoc, $1 . qq{\n$delimiter\n};
4274             push @heredoc_delimiter, $delimiter;
4275 0         0 }
4276             else {
4277 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4278             }
4279             return $here_quote;
4280             }
4281              
4282 0         0 # <<"HEREDOC"
4283 36         80 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4284 36         83 $slash = 'm//';
4285             my $here_quote = $1;
4286             my $delimiter = $2;
4287 36 50       82  
4288 36         84 # get here document
4289 36         292 if ($here_script eq '') {
4290             $here_script = CORE::substr $_, pos $_;
4291 36 50       209 $here_script =~ s/.*?\n//oxm;
4292 36         444 }
4293 36         107 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4294             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4295             push @heredoc_delimiter, $delimiter;
4296 36         80 }
4297             else {
4298 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4299             }
4300             return $here_quote;
4301             }
4302              
4303 36         144 # <
4304 42         99 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4305 42         89 $slash = 'm//';
4306             my $here_quote = $1;
4307             my $delimiter = $2;
4308 42 50       79  
4309 42         105 # get here document
4310 42         302 if ($here_script eq '') {
4311             $here_script = CORE::substr $_, pos $_;
4312 42 50       281 $here_script =~ s/.*?\n//oxm;
4313 42         570 }
4314 42         144 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4315             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4316             push @heredoc_delimiter, $delimiter;
4317 42         96 }
4318             else {
4319 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4320             }
4321             return $here_quote;
4322             }
4323              
4324 42         179 # <<`HEREDOC`
4325 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4326 0         0 $slash = 'm//';
4327             my $here_quote = $1;
4328             my $delimiter = $2;
4329 0 0       0  
4330 0         0 # get here document
4331 0         0 if ($here_script eq '') {
4332             $here_script = CORE::substr $_, pos $_;
4333 0 0       0 $here_script =~ s/.*?\n//oxm;
4334 0         0 }
4335 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4336             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4337             push @heredoc_delimiter, $delimiter;
4338 0         0 }
4339             else {
4340 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4341             }
4342             return $here_quote;
4343             }
4344              
4345 0         0 # <<= <=> <= < operator
4346             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4347             return $1;
4348             }
4349              
4350 12         60 #
4351             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4352             return $1;
4353             }
4354              
4355             # --- glob
4356              
4357             # avoid "Error: Runtime exception" of perl version 5.005_03
4358 0         0  
4359             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4360             return 'Elatin5::glob("' . $1 . '")';
4361             }
4362 0         0  
4363             # __DATA__
4364             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4365 0         0  
4366             # __END__
4367             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4368              
4369             # \cD Control-D
4370              
4371             # P.68 2.6.8. Other Literal Tokens
4372             # in Chapter 2: Bits and Pieces
4373             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4374              
4375             # P.76 Other Literal Tokens
4376             # in Chapter 2: Bits and Pieces
4377 204         1520 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4378              
4379             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4380 0         0  
4381             # \cZ Control-Z
4382             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4383              
4384             # any operator before div
4385             elsif (/\G (
4386             -- | \+\+ |
4387 0         0 [\)\}\]]
  5081         9876  
4388              
4389             ) /oxgc) { $slash = 'div'; return $1; }
4390              
4391             # yada-yada or triple-dot operator
4392             elsif (/\G (
4393 5081         21857 \.\.\.
  7         14  
4394              
4395             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4396              
4397             # any operator before m//
4398              
4399             # //, //= (defined-or)
4400              
4401             # P.164 Logical Operators
4402             # in Chapter 10: More Control Structures
4403             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4404              
4405             # P.119 C-Style Logical (Short-Circuit) Operators
4406             # in Chapter 3: Unary and Binary Operators
4407             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4408              
4409             # (and so on)
4410              
4411             # ~~
4412              
4413             # P.221 The Smart Match Operator
4414             # in Chapter 15: Smart Matching and given-when
4415             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4416              
4417             # P.112 Smartmatch Operator
4418             # in Chapter 3: Unary and Binary Operators
4419             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4420              
4421             # (and so on)
4422              
4423             elsif (/\G ((?>
4424              
4425             !~~ | !~ | != | ! |
4426             %= | % |
4427             &&= | && | &= | &\.= | &\. | & |
4428             -= | -> | - |
4429             :(?>\s*)= |
4430             : |
4431             <<>> |
4432             <<= | <=> | <= | < |
4433             == | => | =~ | = |
4434             >>= | >> | >= | > |
4435             \*\*= | \*\* | \*= | \* |
4436             \+= | \+ |
4437             \.\. | \.= | \. |
4438             \/\/= | \/\/ |
4439             \/= | \/ |
4440             \? |
4441             \\ |
4442             \^= | \^\.= | \^\. | \^ |
4443             \b x= |
4444             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4445             ~~ | ~\. | ~ |
4446             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4447             \b(?: print )\b |
4448              
4449 7         24 [,;\(\{\[]
  8824         17117  
4450              
4451             )) /oxgc) { $slash = 'm//'; return $1; }
4452 8824         40007  
  15137         27867  
4453             # other any character
4454             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4455              
4456 15137         65796 # system error
4457             else {
4458             die __FILE__, ": Oops, this shouldn't happen!\n";
4459             }
4460             }
4461              
4462 0     1786 0 0 # escape Latin-5 string
4463 1786         4015 sub e_string {
4464             my($string) = @_;
4465 1786         2510 my $e_string = '';
4466              
4467             local $slash = 'm//';
4468              
4469             # P.1024 Appendix W.10 Multibyte Processing
4470             # of ISBN 1-56592-224-7 CJKV Information Processing
4471 1786         2489 # (and so on)
4472              
4473             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4474 1786 100 66     13243  
4475 1786 50       7581 # without { ... }
4476 1769         3807 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4477             if ($string !~ /<
4478             return $string;
4479             }
4480             }
4481 1769         4316  
4482 17 50       58 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          
4483             while ($string !~ /\G \z/oxgc) {
4484             if (0) {
4485             }
4486 190         11216  
4487 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin5::PREMATCH()]}
4488 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4489             $e_string .= q{Elatin5::PREMATCH()};
4490             $slash = 'div';
4491             }
4492              
4493 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin5::MATCH()]}
4494 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4495             $e_string .= q{Elatin5::MATCH()};
4496             $slash = 'div';
4497             }
4498              
4499 0         0 # $', ${'} --> $', ${'}
4500 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4501             $e_string .= $1;
4502             $slash = 'div';
4503             }
4504              
4505 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin5::POSTMATCH()]}
4506 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4507             $e_string .= q{Elatin5::POSTMATCH()};
4508             $slash = 'div';
4509             }
4510              
4511 0         0 # bareword
4512 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4513             $e_string .= $1;
4514             $slash = 'div';
4515             }
4516              
4517 0         0 # $0 --> $0
4518 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4519             $e_string .= $1;
4520             $slash = 'div';
4521 0         0 }
4522 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4523             $e_string .= $1;
4524             $slash = 'div';
4525             }
4526              
4527 0         0 # $$ --> $$
4528 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4529             $e_string .= $1;
4530             $slash = 'div';
4531             }
4532              
4533             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4534 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4535 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4536             $e_string .= e_capture($1);
4537             $slash = 'div';
4538 0         0 }
4539 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4540             $e_string .= e_capture($1);
4541             $slash = 'div';
4542             }
4543              
4544 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4545 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4546             $e_string .= e_capture($1.'->'.$2);
4547             $slash = 'div';
4548             }
4549              
4550 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4551 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4552             $e_string .= e_capture($1.'->'.$2);
4553             $slash = 'div';
4554             }
4555              
4556 0         0 # $$foo
4557 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4558             $e_string .= e_capture($1);
4559             $slash = 'div';
4560             }
4561              
4562 0         0 # ${ foo }
4563 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4564             $e_string .= '${' . $1 . '}';
4565             $slash = 'div';
4566             }
4567              
4568 0         0 # ${ ... }
4569 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4570             $e_string .= e_capture($1);
4571             $slash = 'div';
4572             }
4573              
4574             # variable or function
4575 3         15 # $ @ % & * $ #
4576 7         24 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) {
4577             $e_string .= $1;
4578             $slash = 'div';
4579             }
4580             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4581 7         23 # $ @ # \ ' " / ? ( ) [ ] < >
4582 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4583             $e_string .= $1;
4584             $slash = 'div';
4585             }
4586 0         0  
  0         0  
4587 0         0 # subroutines of package Elatin5
  0         0  
4588 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4589 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4590 0         0 elsif ($string =~ /\G \b Latin5::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4591 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4592 0         0 elsif ($string =~ /\G \b Latin5::eval \b /oxgc) { $e_string .= 'eval Latin5::escape'; $slash = 'm//'; }
  0         0  
4593 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4594 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin5::chop'; $slash = 'm//'; }
  0         0  
4595 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4596 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4597 0         0 elsif ($string =~ /\G \b Latin5::index \b /oxgc) { $e_string .= 'Latin5::index'; $slash = 'm//'; }
  0         0  
4598 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin5::index'; $slash = 'm//'; }
  0         0  
4599 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4600 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4601 0         0 elsif ($string =~ /\G \b Latin5::rindex \b /oxgc) { $e_string .= 'Latin5::rindex'; $slash = 'm//'; }
  0         0  
4602 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin5::rindex'; $slash = 'm//'; }
  0         0  
4603 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::lc'; $slash = 'm//'; }
  0         0  
4604 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::lcfirst'; $slash = 'm//'; }
  0         0  
4605 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::uc'; $slash = 'm//'; }
  0         0  
4606             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::ucfirst'; $slash = 'm//'; }
4607             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::fc'; $slash = 'm//'; }
4608 0         0  
  0         0  
4609 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4610 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4611 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  
4612 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  
4613 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  
4614 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  
4615             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4616 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  
4617 0         0  
  0         0  
4618 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4619 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  
4620 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  
4621 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  
4622 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  
4623             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4624             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4625 0         0  
  0         0  
4626 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4627 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4628 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4629             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4630 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4631 0         0  
  0         0  
4632 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4633 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4634 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::chr'; $slash = 'm//'; }
  0         0  
4635 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4636 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4637 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::glob'; $slash = 'm//'; }
  0         0  
4638 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin5::lc_'; $slash = 'm//'; }
  0         0  
4639 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin5::lcfirst_'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin5::uc_'; $slash = 'm//'; }
  0         0  
4641 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin5::ucfirst_'; $slash = 'm//'; }
  0         0  
4642             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin5::fc_'; $slash = 'm//'; }
4643 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4644 0         0  
  0         0  
4645 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4646 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4647 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin5::chr_'; $slash = 'm//'; }
  0         0  
4648 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4649 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4650 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin5::glob_'; $slash = 'm//'; }
  0         0  
4651             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4652             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4653 0         0 # split
4654             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4655 0         0 $slash = 'm//';
4656 0         0  
4657 0         0 my $e = '';
4658             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4659             $e .= $1;
4660             }
4661 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4662             # end of split
4663             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin5::split' . $e; }
4664 0         0  
  0         0  
4665             # split scalar value
4666             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin5::split' . $e . e_string($1); next E_STRING_LOOP; }
4667 0         0  
  0         0  
4668 0         0 # split literal space
  0         0  
4669 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4670 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4671 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4674 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4677 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4678 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4679 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4680 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4681             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {' '}; next E_STRING_LOOP; }
4682             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {" "}; next E_STRING_LOOP; }
4683              
4684 0 0       0 # split qq//
  0         0  
  0         0  
4685             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4686 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4687 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4688 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4689 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4690 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  
4691 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  
4692 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  
4693 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  
4694             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4695 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 * *
4696             }
4697             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4698             }
4699             }
4700              
4701 0 0       0 # split qr//
  0         0  
  0         0  
4702             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4703 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4704 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4705 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4706 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4707 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  
4708 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  
4709 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  
4710 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  
4711 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  
4712             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4713 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 * *
4714             }
4715             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4716             }
4717             }
4718              
4719 0 0       0 # split q//
  0         0  
  0         0  
4720             elsif ($string =~ /\G \b (q) \b /oxgc) {
4721 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4722 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4723 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4724 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4725 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4726 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  
4727 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  
4728 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  
4729             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4730 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 * *
4731             }
4732             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4733             }
4734             }
4735              
4736 0 0       0 # split m//
  0         0  
  0         0  
4737             elsif ($string =~ /\G \b (m) \b /oxgc) {
4738 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 # #
4739 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4740 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4741 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4742 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  
4743 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  
4744 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  
4745 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  
4746 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  
4747             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4748 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 * *
4749             }
4750             die __FILE__, ": Search pattern not terminated\n";
4751             }
4752             }
4753              
4754 0         0 # split ''
4755 0         0 elsif ($string =~ /\G (\') /oxgc) {
4756 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4757 0         0 while ($string !~ /\G \z/oxgc) {
4758 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4759 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4760             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4761 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4762             }
4763             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4764             }
4765              
4766 0         0 # split ""
4767 0         0 elsif ($string =~ /\G (\") /oxgc) {
4768 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4769 0         0 while ($string !~ /\G \z/oxgc) {
4770 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4771 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4772             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4773 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4774             }
4775             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4776             }
4777              
4778 0         0 # split //
4779 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4780 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4781 0         0 while ($string !~ /\G \z/oxgc) {
4782 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4783 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4784             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4785 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4786             }
4787             die __FILE__, ": Search pattern not terminated\n";
4788             }
4789             }
4790              
4791 0         0 # qq//
4792 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4793 0         0 my $ope = $1;
4794             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4795             $e_string .= e_qq($ope,$1,$3,$2);
4796 0         0 }
4797 0         0 else {
4798 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4799 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4800 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4801 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4802 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4803 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4804             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4805 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4806             }
4807             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4808             }
4809             }
4810              
4811 0         0 # qx//
4812 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4813 0         0 my $ope = $1;
4814             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4815             $e_string .= e_qq($ope,$1,$3,$2);
4816 0         0 }
4817 0         0 else {
4818 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4819 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4820 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4821 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4822 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4823 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4824 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4825             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4826 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4827             }
4828             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4829             }
4830             }
4831              
4832 0         0 # q//
4833 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4834 0         0 my $ope = $1;
4835             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4836             $e_string .= e_q($ope,$1,$3,$2);
4837 0         0 }
4838 0         0 else {
4839 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4840 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4841 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4842 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4843 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4844 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4845             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4846 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 * *
4847             }
4848             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4849             }
4850             }
4851 0         0  
4852             # ''
4853             elsif ($string =~ /\G (?
4854 0         0  
4855             # ""
4856             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4857 0         0  
4858             # ``
4859             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4860 0         0  
4861             # <<>> (a safer ARGV)
4862             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4863 0         0  
4864             # <<= <=> <= < operator
4865             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4866 0         0  
4867             #
4868             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4869              
4870 0         0 # --- glob
4871             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4872             $e_string .= 'Elatin5::glob("' . $1 . '")';
4873             }
4874              
4875 0         0 # << (bit shift) --- not here document
4876 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4877             $slash = 'm//';
4878             $e_string .= $1;
4879             }
4880              
4881 0         0 # <<~'HEREDOC'
4882 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4883 0         0 $slash = 'm//';
4884             my $here_quote = $1;
4885             my $delimiter = $2;
4886 0 0       0  
4887 0         0 # get here document
4888 0         0 if ($here_script eq '') {
4889             $here_script = CORE::substr $_, pos $_;
4890 0 0       0 $here_script =~ s/.*?\n//oxm;
4891 0         0 }
4892 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4893 0         0 my $heredoc = $1;
4894 0         0 my $indent = $2;
4895 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4896             push @heredoc, $heredoc . qq{\n$delimiter\n};
4897             push @heredoc_delimiter, qq{\\s*$delimiter};
4898 0         0 }
4899             else {
4900 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4901             }
4902             $e_string .= qq{<<'$delimiter'};
4903             }
4904              
4905 0         0 # <<~\HEREDOC
4906 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4907 0         0 $slash = 'm//';
4908             my $here_quote = $1;
4909             my $delimiter = $2;
4910 0 0       0  
4911 0         0 # get here document
4912 0         0 if ($here_script eq '') {
4913             $here_script = CORE::substr $_, pos $_;
4914 0 0       0 $here_script =~ s/.*?\n//oxm;
4915 0         0 }
4916 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4917 0         0 my $heredoc = $1;
4918 0         0 my $indent = $2;
4919 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4920             push @heredoc, $heredoc . qq{\n$delimiter\n};
4921             push @heredoc_delimiter, qq{\\s*$delimiter};
4922 0         0 }
4923             else {
4924 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4925             }
4926             $e_string .= qq{<<\\$delimiter};
4927             }
4928              
4929 0         0 # <<~"HEREDOC"
4930 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4931 0         0 $slash = 'm//';
4932             my $here_quote = $1;
4933             my $delimiter = $2;
4934 0 0       0  
4935 0         0 # get here document
4936 0         0 if ($here_script eq '') {
4937             $here_script = CORE::substr $_, pos $_;
4938 0 0       0 $here_script =~ s/.*?\n//oxm;
4939 0         0 }
4940 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4941 0         0 my $heredoc = $1;
4942 0         0 my $indent = $2;
4943 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4944             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4945             push @heredoc_delimiter, qq{\\s*$delimiter};
4946 0         0 }
4947             else {
4948 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4949             }
4950             $e_string .= qq{<<"$delimiter"};
4951             }
4952              
4953 0         0 # <<~HEREDOC
4954 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4955 0         0 $slash = 'm//';
4956             my $here_quote = $1;
4957             my $delimiter = $2;
4958 0 0       0  
4959 0         0 # get here document
4960 0         0 if ($here_script eq '') {
4961             $here_script = CORE::substr $_, pos $_;
4962 0 0       0 $here_script =~ s/.*?\n//oxm;
4963 0         0 }
4964 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4965 0         0 my $heredoc = $1;
4966 0         0 my $indent = $2;
4967 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4968             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4969             push @heredoc_delimiter, qq{\\s*$delimiter};
4970 0         0 }
4971             else {
4972 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4973             }
4974             $e_string .= qq{<<$delimiter};
4975             }
4976              
4977 0         0 # <<~`HEREDOC`
4978 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4979 0         0 $slash = 'm//';
4980             my $here_quote = $1;
4981             my $delimiter = $2;
4982 0 0       0  
4983 0         0 # get here document
4984 0         0 if ($here_script eq '') {
4985             $here_script = CORE::substr $_, pos $_;
4986 0 0       0 $here_script =~ s/.*?\n//oxm;
4987 0         0 }
4988 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4989 0         0 my $heredoc = $1;
4990 0         0 my $indent = $2;
4991 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4992             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4993             push @heredoc_delimiter, qq{\\s*$delimiter};
4994 0         0 }
4995             else {
4996 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4997             }
4998             $e_string .= qq{<<`$delimiter`};
4999             }
5000              
5001 0         0 # <<'HEREDOC'
5002 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5003 0         0 $slash = 'm//';
5004             my $here_quote = $1;
5005             my $delimiter = $2;
5006 0 0       0  
5007 0         0 # get here document
5008 0         0 if ($here_script eq '') {
5009             $here_script = CORE::substr $_, pos $_;
5010 0 0       0 $here_script =~ s/.*?\n//oxm;
5011 0         0 }
5012 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5013             push @heredoc, $1 . qq{\n$delimiter\n};
5014             push @heredoc_delimiter, $delimiter;
5015 0         0 }
5016             else {
5017 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5018             }
5019             $e_string .= $here_quote;
5020             }
5021              
5022 0         0 # <<\HEREDOC
5023 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5024 0         0 $slash = 'm//';
5025             my $here_quote = $1;
5026             my $delimiter = $2;
5027 0 0       0  
5028 0         0 # get here document
5029 0         0 if ($here_script eq '') {
5030             $here_script = CORE::substr $_, pos $_;
5031 0 0       0 $here_script =~ s/.*?\n//oxm;
5032 0         0 }
5033 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5034             push @heredoc, $1 . qq{\n$delimiter\n};
5035             push @heredoc_delimiter, $delimiter;
5036 0         0 }
5037             else {
5038 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5039             }
5040             $e_string .= $here_quote;
5041             }
5042              
5043 0         0 # <<"HEREDOC"
5044 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5045 0         0 $slash = 'm//';
5046             my $here_quote = $1;
5047             my $delimiter = $2;
5048 0 0       0  
5049 0         0 # get here document
5050 0         0 if ($here_script eq '') {
5051             $here_script = CORE::substr $_, pos $_;
5052 0 0       0 $here_script =~ s/.*?\n//oxm;
5053 0         0 }
5054 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5055             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5056             push @heredoc_delimiter, $delimiter;
5057 0         0 }
5058             else {
5059 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5060             }
5061             $e_string .= $here_quote;
5062             }
5063              
5064 0         0 # <
5065 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5066 0         0 $slash = 'm//';
5067             my $here_quote = $1;
5068             my $delimiter = $2;
5069 0 0       0  
5070 0         0 # get here document
5071 0         0 if ($here_script eq '') {
5072             $here_script = CORE::substr $_, pos $_;
5073 0 0       0 $here_script =~ s/.*?\n//oxm;
5074 0         0 }
5075 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5076             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5077             push @heredoc_delimiter, $delimiter;
5078 0         0 }
5079             else {
5080 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5081             }
5082             $e_string .= $here_quote;
5083             }
5084              
5085 0         0 # <<`HEREDOC`
5086 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5087 0         0 $slash = 'm//';
5088             my $here_quote = $1;
5089             my $delimiter = $2;
5090 0 0       0  
5091 0         0 # get here document
5092 0         0 if ($here_script eq '') {
5093             $here_script = CORE::substr $_, pos $_;
5094 0 0       0 $here_script =~ s/.*?\n//oxm;
5095 0         0 }
5096 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5097             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5098             push @heredoc_delimiter, $delimiter;
5099 0         0 }
5100             else {
5101 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5102             }
5103             $e_string .= $here_quote;
5104             }
5105              
5106             # any operator before div
5107             elsif ($string =~ /\G (
5108             -- | \+\+ |
5109 0         0 [\)\}\]]
  18         30  
5110              
5111             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5112              
5113             # yada-yada or triple-dot operator
5114             elsif ($string =~ /\G (
5115 18         57 \.\.\.
  0         0  
5116              
5117             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5118              
5119             # any operator before m//
5120             elsif ($string =~ /\G ((?>
5121              
5122             !~~ | !~ | != | ! |
5123             %= | % |
5124             &&= | && | &= | &\.= | &\. | & |
5125             -= | -> | - |
5126             :(?>\s*)= |
5127             : |
5128             <<>> |
5129             <<= | <=> | <= | < |
5130             == | => | =~ | = |
5131             >>= | >> | >= | > |
5132             \*\*= | \*\* | \*= | \* |
5133             \+= | \+ |
5134             \.\. | \.= | \. |
5135             \/\/= | \/\/ |
5136             \/= | \/ |
5137             \? |
5138             \\ |
5139             \^= | \^\.= | \^\. | \^ |
5140             \b x= |
5141             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5142             ~~ | ~\. | ~ |
5143             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5144             \b(?: print )\b |
5145              
5146 0         0 [,;\(\{\[]
  31         57  
5147              
5148             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5149 31         104  
5150             # other any character
5151             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5152              
5153 131         338 # system error
5154             else {
5155             die __FILE__, ": Oops, this shouldn't happen!\n";
5156             }
5157 0         0 }
5158              
5159             return $e_string;
5160             }
5161              
5162             #
5163             # character class
5164 17     1919 0 85 #
5165             sub character_class {
5166 1919 100       3446 my($char,$modifier) = @_;
5167 1919 100       3152  
5168 52         103 if ($char eq '.') {
5169             if ($modifier =~ /s/) {
5170             return '${Elatin5::dot_s}';
5171 17         40 }
5172             else {
5173             return '${Elatin5::dot}';
5174             }
5175 35         72 }
5176             else {
5177             return Elatin5::classic_character_class($char);
5178             }
5179             }
5180              
5181             #
5182             # escape capture ($1, $2, $3, ...)
5183             #
5184 1867     212 0 3294 sub e_capture {
5185              
5186             return join '', '${', $_[0], '}';
5187             }
5188              
5189             #
5190             # escape transliteration (tr/// or y///)
5191 212     3 0 750 #
5192 3         23 sub e_tr {
5193 3   50     7 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5194             my $e_tr = '';
5195 3         7 $modifier ||= '';
5196              
5197             $slash = 'div';
5198 3         5  
5199             # quote character class 1
5200             $charclass = q_tr($charclass);
5201 3         9  
5202             # quote character class 2
5203             $charclass2 = q_tr($charclass2);
5204 3 50       7  
5205 3 0       13 # /b /B modifier
5206 0         0 if ($modifier =~ tr/bB//d) {
5207             if ($variable eq '') {
5208             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5209 0         0 }
5210             else {
5211             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5212             }
5213 0 100       0 }
5214 3         9 else {
5215             if ($variable eq '') {
5216             $e_tr = qq{Elatin5::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5217 2         7 }
5218             else {
5219             $e_tr = qq{Elatin5::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5220             }
5221             }
5222 1         6  
5223 3         7 # clear tr/// variable
5224             $tr_variable = '';
5225 3         5 $bind_operator = '';
5226              
5227             return $e_tr;
5228             }
5229              
5230             #
5231             # quote for escape transliteration (tr/// or y///)
5232 3     6 0 18 #
5233             sub q_tr {
5234             my($charclass) = @_;
5235 6 50       12  
    0          
    0          
    0          
    0          
    0          
5236 6         15 # quote character class
5237             if ($charclass !~ /'/oxms) {
5238             return e_q('', "'", "'", $charclass); # --> q' '
5239 6         17 }
5240             elsif ($charclass !~ /\//oxms) {
5241             return e_q('q', '/', '/', $charclass); # --> q/ /
5242 0         0 }
5243             elsif ($charclass !~ /\#/oxms) {
5244             return e_q('q', '#', '#', $charclass); # --> q# #
5245 0         0 }
5246             elsif ($charclass !~ /[\<\>]/oxms) {
5247             return e_q('q', '<', '>', $charclass); # --> q< >
5248 0         0 }
5249             elsif ($charclass !~ /[\(\)]/oxms) {
5250             return e_q('q', '(', ')', $charclass); # --> q( )
5251 0         0 }
5252             elsif ($charclass !~ /[\{\}]/oxms) {
5253             return e_q('q', '{', '}', $charclass); # --> q{ }
5254 0         0 }
5255 0 0       0 else {
5256 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5257             if ($charclass !~ /\Q$char\E/xms) {
5258             return e_q('q', $char, $char, $charclass);
5259             }
5260             }
5261 0         0 }
5262              
5263             return e_q('q', '{', '}', $charclass);
5264             }
5265              
5266             #
5267             # escape q string (q//, '')
5268 0     1264 0 0 #
5269             sub e_q {
5270 1264         2970 my($ope,$delimiter,$end_delimiter,$string) = @_;
5271              
5272 1264         1638 $slash = 'div';
5273              
5274             return join '', $ope, $delimiter, $string, $end_delimiter;
5275             }
5276              
5277             #
5278             # escape qq string (qq//, "", qx//, ``)
5279 1264     4022 0 6039 #
5280             sub e_qq {
5281 4022         8822 my($ope,$delimiter,$end_delimiter,$string) = @_;
5282              
5283 4022         5081 $slash = 'div';
5284 4022         4699  
5285             my $left_e = 0;
5286             my $right_e = 0;
5287 4022         4409  
5288             # split regexp
5289             my @char = $string =~ /\G((?>
5290             [^\\\$] |
5291             \\x\{ (?>[0-9A-Fa-f]+) \} |
5292             \\o\{ (?>[0-7]+) \} |
5293             \\N\{ (?>[^0-9\}][^\}]*) \} |
5294             \\ $q_char |
5295             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5296             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5297             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5298             \$ (?>\s* [0-9]+) |
5299             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5300             \$ \$ (?![\w\{]) |
5301             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5302             $q_char
5303 4022         132112 ))/oxmsg;
5304              
5305             for (my $i=0; $i <= $#char; $i++) {
5306 4022 50 33     12488  
    50 33        
    100          
    100          
    50          
5307 113709         366830 # "\L\u" --> "\u\L"
5308             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5309             @char[$i,$i+1] = @char[$i+1,$i];
5310             }
5311              
5312 0         0 # "\U\l" --> "\l\U"
5313             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5314             @char[$i,$i+1] = @char[$i+1,$i];
5315             }
5316              
5317 0         0 # octal escape sequence
5318             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5319             $char[$i] = Elatin5::octchr($1);
5320             }
5321              
5322 1         5 # hexadecimal escape sequence
5323             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5324             $char[$i] = Elatin5::hexchr($1);
5325             }
5326              
5327 1         4 # \N{CHARNAME} --> N{CHARNAME}
5328             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5329             $char[$i] = $1;
5330 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          
5331              
5332             if (0) {
5333             }
5334              
5335             # \F
5336             #
5337             # P.69 Table 2-6. Translation escapes
5338             # in Chapter 2: Bits and Pieces
5339             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5340             # (and so on)
5341 113709         875390  
5342 0 50       0 # \u \l \U \L \F \Q \E
5343 484         1077 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5344             if ($right_e < $left_e) {
5345             $char[$i] = '\\' . $char[$i];
5346             }
5347             }
5348             elsif ($char[$i] eq '\u') {
5349              
5350             # "STRING @{[ LIST EXPR ]} MORE STRING"
5351              
5352             # P.257 Other Tricks You Can Do with Hard References
5353             # in Chapter 8: References
5354             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5355              
5356             # P.353 Other Tricks You Can Do with Hard References
5357             # in Chapter 8: References
5358             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5359              
5360 0         0 # (and so on)
5361 0         0  
5362             $char[$i] = '@{[Elatin5::ucfirst qq<';
5363             $left_e++;
5364 0         0 }
5365 0         0 elsif ($char[$i] eq '\l') {
5366             $char[$i] = '@{[Elatin5::lcfirst qq<';
5367             $left_e++;
5368 0         0 }
5369 0         0 elsif ($char[$i] eq '\U') {
5370             $char[$i] = '@{[Elatin5::uc qq<';
5371             $left_e++;
5372 0         0 }
5373 0         0 elsif ($char[$i] eq '\L') {
5374             $char[$i] = '@{[Elatin5::lc qq<';
5375             $left_e++;
5376 0         0 }
5377 24         34 elsif ($char[$i] eq '\F') {
5378             $char[$i] = '@{[Elatin5::fc qq<';
5379             $left_e++;
5380 24         40 }
5381 0         0 elsif ($char[$i] eq '\Q') {
5382             $char[$i] = '@{[CORE::quotemeta qq<';
5383             $left_e++;
5384 0 50       0 }
5385 24         37 elsif ($char[$i] eq '\E') {
5386 24         29 if ($right_e < $left_e) {
5387             $char[$i] = '>]}';
5388             $right_e++;
5389 24         39 }
5390             else {
5391             $char[$i] = '';
5392             }
5393 0         0 }
5394 0 0       0 elsif ($char[$i] eq '\Q') {
5395 0         0 while (1) {
5396             if (++$i > $#char) {
5397 0 0       0 last;
5398 0         0 }
5399             if ($char[$i] eq '\E') {
5400             last;
5401             }
5402             }
5403             }
5404             elsif ($char[$i] eq '\E') {
5405             }
5406              
5407             # $0 --> $0
5408             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5409             }
5410             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5411             }
5412              
5413             # $$ --> $$
5414             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5415             }
5416              
5417             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5418 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5419             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5420             $char[$i] = e_capture($1);
5421 205         373 }
5422             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5423             $char[$i] = e_capture($1);
5424             }
5425              
5426 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5427             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5428             $char[$i] = e_capture($1.'->'.$2);
5429             }
5430              
5431 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5432             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5433             $char[$i] = e_capture($1.'->'.$2);
5434             }
5435              
5436 0         0 # $$foo
5437             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5438             $char[$i] = e_capture($1);
5439             }
5440              
5441 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
5442             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5443             $char[$i] = '@{[Elatin5::PREMATCH()]}';
5444             }
5445              
5446 44         117 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
5447             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5448             $char[$i] = '@{[Elatin5::MATCH()]}';
5449             }
5450              
5451 45         119 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
5452             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5453             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
5454             }
5455              
5456             # ${ foo } --> ${ foo }
5457             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5458             }
5459              
5460 33         89 # ${ ... }
5461             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5462             $char[$i] = e_capture($1);
5463             }
5464             }
5465 0 50       0  
5466 4022         7425 # return string
5467             if ($left_e > $right_e) {
5468 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5469             }
5470             return join '', $ope, $delimiter, @char, $end_delimiter;
5471             }
5472              
5473             #
5474             # escape qw string (qw//)
5475 4022     16 0 31851 #
5476             sub e_qw {
5477 16         73 my($ope,$delimiter,$end_delimiter,$string) = @_;
5478              
5479             $slash = 'div';
5480 16         33  
  16         203  
5481 483 50       745 # choice again delimiter
    0          
    0          
    0          
    0          
5482 16         94 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5483             if (not $octet{$end_delimiter}) {
5484             return join '', $ope, $delimiter, $string, $end_delimiter;
5485 16         122 }
5486             elsif (not $octet{')'}) {
5487             return join '', $ope, '(', $string, ')';
5488 0         0 }
5489             elsif (not $octet{'}'}) {
5490             return join '', $ope, '{', $string, '}';
5491 0         0 }
5492             elsif (not $octet{']'}) {
5493             return join '', $ope, '[', $string, ']';
5494 0         0 }
5495             elsif (not $octet{'>'}) {
5496             return join '', $ope, '<', $string, '>';
5497 0         0 }
5498 0 0       0 else {
5499 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5500             if (not $octet{$char}) {
5501             return join '', $ope, $char, $string, $char;
5502             }
5503             }
5504             }
5505 0         0  
5506 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5507 0         0 my @string = CORE::split(/\s+/, $string);
5508 0         0 for my $string (@string) {
5509 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5510 0         0 for my $octet (@octet) {
5511             if ($octet =~ /\A (['\\]) \z/oxms) {
5512             $octet = '\\' . $1;
5513 0         0 }
5514             }
5515 0         0 $string = join '', @octet;
  0         0  
5516             }
5517             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5518             }
5519              
5520             #
5521             # escape here document (<<"HEREDOC", <
5522 0     93 0 0 #
5523             sub e_heredoc {
5524 93         242 my($string) = @_;
5525              
5526 93         138 $slash = 'm//';
5527              
5528 93         296 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5529 93         135  
5530             my $left_e = 0;
5531             my $right_e = 0;
5532 93         120  
5533             # split regexp
5534             my @char = $string =~ /\G((?>
5535             [^\\\$] |
5536             \\x\{ (?>[0-9A-Fa-f]+) \} |
5537             \\o\{ (?>[0-7]+) \} |
5538             \\N\{ (?>[^0-9\}][^\}]*) \} |
5539             \\ $q_char |
5540             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5541             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5542             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5543             \$ (?>\s* [0-9]+) |
5544             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5545             \$ \$ (?![\w\{]) |
5546             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5547             $q_char
5548 93         7969 ))/oxmsg;
5549              
5550             for (my $i=0; $i <= $#char; $i++) {
5551 93 50 33     450  
    50 33        
    100          
    100          
    50          
5552 3177         9544 # "\L\u" --> "\u\L"
5553             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5554             @char[$i,$i+1] = @char[$i+1,$i];
5555             }
5556              
5557 0         0 # "\U\l" --> "\l\U"
5558             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5559             @char[$i,$i+1] = @char[$i+1,$i];
5560             }
5561              
5562 0         0 # octal escape sequence
5563             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5564             $char[$i] = Elatin5::octchr($1);
5565             }
5566              
5567 1         4 # hexadecimal escape sequence
5568             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5569             $char[$i] = Elatin5::hexchr($1);
5570             }
5571              
5572 1         3 # \N{CHARNAME} --> N{CHARNAME}
5573             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5574             $char[$i] = $1;
5575 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          
5576              
5577             if (0) {
5578             }
5579 3177         24658  
5580 0 0       0 # \u \l \U \L \F \Q \E
5581 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5582             if ($right_e < $left_e) {
5583             $char[$i] = '\\' . $char[$i];
5584             }
5585 0         0 }
5586 0         0 elsif ($char[$i] eq '\u') {
5587             $char[$i] = '@{[Elatin5::ucfirst qq<';
5588             $left_e++;
5589 0         0 }
5590 0         0 elsif ($char[$i] eq '\l') {
5591             $char[$i] = '@{[Elatin5::lcfirst qq<';
5592             $left_e++;
5593 0         0 }
5594 0         0 elsif ($char[$i] eq '\U') {
5595             $char[$i] = '@{[Elatin5::uc qq<';
5596             $left_e++;
5597 0         0 }
5598 0         0 elsif ($char[$i] eq '\L') {
5599             $char[$i] = '@{[Elatin5::lc qq<';
5600             $left_e++;
5601 0         0 }
5602 0         0 elsif ($char[$i] eq '\F') {
5603             $char[$i] = '@{[Elatin5::fc qq<';
5604             $left_e++;
5605 0         0 }
5606 0         0 elsif ($char[$i] eq '\Q') {
5607             $char[$i] = '@{[CORE::quotemeta qq<';
5608             $left_e++;
5609 0 0       0 }
5610 0         0 elsif ($char[$i] eq '\E') {
5611 0         0 if ($right_e < $left_e) {
5612             $char[$i] = '>]}';
5613             $right_e++;
5614 0         0 }
5615             else {
5616             $char[$i] = '';
5617             }
5618 0         0 }
5619 0 0       0 elsif ($char[$i] eq '\Q') {
5620 0         0 while (1) {
5621             if (++$i > $#char) {
5622 0 0       0 last;
5623 0         0 }
5624             if ($char[$i] eq '\E') {
5625             last;
5626             }
5627             }
5628             }
5629             elsif ($char[$i] eq '\E') {
5630             }
5631              
5632             # $0 --> $0
5633             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5634             }
5635             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5636             }
5637              
5638             # $$ --> $$
5639             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5640             }
5641              
5642             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5643 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5644             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5645             $char[$i] = e_capture($1);
5646 0         0 }
5647             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5648             $char[$i] = e_capture($1);
5649             }
5650              
5651 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5652             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5653             $char[$i] = e_capture($1.'->'.$2);
5654             }
5655              
5656 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5657             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5658             $char[$i] = e_capture($1.'->'.$2);
5659             }
5660              
5661 0         0 # $$foo
5662             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5663             $char[$i] = e_capture($1);
5664             }
5665              
5666 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
5667             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5668             $char[$i] = '@{[Elatin5::PREMATCH()]}';
5669             }
5670              
5671 8         45 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
5672             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5673             $char[$i] = '@{[Elatin5::MATCH()]}';
5674             }
5675              
5676 8         98 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
5677             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5678             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
5679             }
5680              
5681             # ${ foo } --> ${ foo }
5682             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5683             }
5684              
5685 6         32 # ${ ... }
5686             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5687             $char[$i] = e_capture($1);
5688             }
5689             }
5690 0 50       0  
5691 93         195 # return string
5692             if ($left_e > $right_e) {
5693 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5694             }
5695             return join '', @char;
5696             }
5697              
5698             #
5699             # escape regexp (m//, qr//)
5700 93     652 0 747 #
5701 652   100     2685 sub e_qr {
5702             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5703 652         2618 $modifier ||= '';
5704 652 50       1115  
5705 652         1508 $modifier =~ tr/p//d;
5706 0         0 if ($modifier =~ /([adlu])/oxms) {
5707 0 0       0 my $line = 0;
5708 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5709 0         0 if ($filename ne __FILE__) {
5710             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5711             last;
5712 0         0 }
5713             }
5714             die qq{Unsupported modifier "$1" used at line $line.\n};
5715 0         0 }
5716              
5717             $slash = 'div';
5718 652 100       982  
    100          
5719 652         2507 # literal null string pattern
5720 8         11 if ($string eq '') {
5721 8         12 $modifier =~ tr/bB//d;
5722             $modifier =~ tr/i//d;
5723             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5724             }
5725              
5726             # /b /B modifier
5727             elsif ($modifier =~ tr/bB//d) {
5728 8 50       44  
5729 2         6 # choice again delimiter
5730 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5731 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5732 0         0 my %octet = map {$_ => 1} @char;
5733 0         0 if (not $octet{')'}) {
5734             $delimiter = '(';
5735             $end_delimiter = ')';
5736 0         0 }
5737 0         0 elsif (not $octet{'}'}) {
5738             $delimiter = '{';
5739             $end_delimiter = '}';
5740 0         0 }
5741 0         0 elsif (not $octet{']'}) {
5742             $delimiter = '[';
5743             $end_delimiter = ']';
5744 0         0 }
5745 0         0 elsif (not $octet{'>'}) {
5746             $delimiter = '<';
5747             $end_delimiter = '>';
5748 0         0 }
5749 0 0       0 else {
5750 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5751 0         0 if (not $octet{$char}) {
5752 0         0 $delimiter = $char;
5753             $end_delimiter = $char;
5754             last;
5755             }
5756             }
5757             }
5758 0 50 33     0 }
5759 2         9  
5760             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5761             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5762 0         0 }
5763             else {
5764             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5765             }
5766 2 100       10 }
5767 642         1375  
5768             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5769             my $metachar = qr/[\@\\|[\]{^]/oxms;
5770 642         2392  
5771             # split regexp
5772             my @char = $string =~ /\G((?>
5773             [^\\\$\@\[\(] |
5774             \\x (?>[0-9A-Fa-f]{1,2}) |
5775             \\ (?>[0-7]{2,3}) |
5776             \\c [\x40-\x5F] |
5777             \\x\{ (?>[0-9A-Fa-f]+) \} |
5778             \\o\{ (?>[0-7]+) \} |
5779             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5780             \\ $q_char |
5781             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5782             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5783             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5784             [\$\@] $qq_variable |
5785             \$ (?>\s* [0-9]+) |
5786             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5787             \$ \$ (?![\w\{]) |
5788             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5789             \[\^ |
5790             \[\: (?>[a-z]+) :\] |
5791             \[\:\^ (?>[a-z]+) :\] |
5792             \(\? |
5793             $q_char
5794             ))/oxmsg;
5795 642 50       63429  
5796 642         2722 # choice again delimiter
  0         0  
5797 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5798 0         0 my %octet = map {$_ => 1} @char;
5799 0         0 if (not $octet{')'}) {
5800             $delimiter = '(';
5801             $end_delimiter = ')';
5802 0         0 }
5803 0         0 elsif (not $octet{'}'}) {
5804             $delimiter = '{';
5805             $end_delimiter = '}';
5806 0         0 }
5807 0         0 elsif (not $octet{']'}) {
5808             $delimiter = '[';
5809             $end_delimiter = ']';
5810 0         0 }
5811 0         0 elsif (not $octet{'>'}) {
5812             $delimiter = '<';
5813             $end_delimiter = '>';
5814 0         0 }
5815 0 0       0 else {
5816 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5817 0         0 if (not $octet{$char}) {
5818 0         0 $delimiter = $char;
5819             $end_delimiter = $char;
5820             last;
5821             }
5822             }
5823             }
5824 0         0 }
5825 642         1092  
5826 642         863 my $left_e = 0;
5827             my $right_e = 0;
5828             for (my $i=0; $i <= $#char; $i++) {
5829 642 50 66     1579  
    50 66        
    100          
    100          
    100          
    100          
5830 1872         9382 # "\L\u" --> "\u\L"
5831             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5832             @char[$i,$i+1] = @char[$i+1,$i];
5833             }
5834              
5835 0         0 # "\U\l" --> "\l\U"
5836             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5837             @char[$i,$i+1] = @char[$i+1,$i];
5838             }
5839              
5840 0         0 # octal escape sequence
5841             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5842             $char[$i] = Elatin5::octchr($1);
5843             }
5844              
5845 1         4 # hexadecimal escape sequence
5846             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5847             $char[$i] = Elatin5::hexchr($1);
5848             }
5849              
5850             # \b{...} --> b\{...}
5851             # \B{...} --> B\{...}
5852             # \N{CHARNAME} --> N\{CHARNAME}
5853             # \p{PROPERTY} --> p\{PROPERTY}
5854 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5855             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5856             $char[$i] = $1 . '\\' . $2;
5857             }
5858              
5859 6         20 # \p, \P, \X --> p, P, X
5860             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5861             $char[$i] = $1;
5862 4 100 100     11 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5863              
5864             if (0) {
5865             }
5866 1872         5345  
5867 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5868 6         83 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5869             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)) {
5870             $char[$i] .= join '', splice @char, $i+1, 3;
5871 0         0 }
5872             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)) {
5873             $char[$i] .= join '', splice @char, $i+1, 2;
5874 0         0 }
5875             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)) {
5876             $char[$i] .= join '', splice @char, $i+1, 1;
5877             }
5878             }
5879              
5880 0         0 # open character class [...]
5881             elsif ($char[$i] eq '[') {
5882             my $left = $i;
5883              
5884             # [] make die "Unmatched [] in regexp ...\n"
5885 328 100       540 # (and so on)
5886 328         738  
5887             if ($char[$i+1] eq ']') {
5888             $i++;
5889 3         7 }
5890 328 50       405  
5891 1379         2082 while (1) {
5892             if (++$i > $#char) {
5893 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5894 1379         2094 }
5895             if ($char[$i] eq ']') {
5896             my $right = $i;
5897 328 100       412  
5898 328         1592 # [...]
  30         75  
5899             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5900             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5901 90         140 }
5902             else {
5903             splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
5904 298         1198 }
5905 328         561  
5906             $i = $left;
5907             last;
5908             }
5909             }
5910             }
5911              
5912 328         877 # open character class [^...]
5913             elsif ($char[$i] eq '[^') {
5914             my $left = $i;
5915              
5916             # [^] make die "Unmatched [] in regexp ...\n"
5917 74 100       101 # (and so on)
5918 74         168  
5919             if ($char[$i+1] eq ']') {
5920             $i++;
5921 4         6 }
5922 74 50       87  
5923 272         406 while (1) {
5924             if (++$i > $#char) {
5925 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5926 272         399 }
5927             if ($char[$i] eq ']') {
5928             my $right = $i;
5929 74 100       85  
5930 74         376 # [^...]
  30         65  
5931             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5932             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5933 90         148 }
5934             else {
5935             splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5936 44         178 }
5937 74         148  
5938             $i = $left;
5939             last;
5940             }
5941             }
5942             }
5943              
5944 74         194 # rewrite character class or escape character
5945             elsif (my $char = character_class($char[$i],$modifier)) {
5946             $char[$i] = $char;
5947             }
5948              
5949 139 50       324 # /i modifier
5950 20         35 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
5951             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
5952             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
5953 20         35 }
5954             else {
5955             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
5956             }
5957             }
5958              
5959 0 50       0 # \u \l \U \L \F \Q \E
5960 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5961             if ($right_e < $left_e) {
5962             $char[$i] = '\\' . $char[$i];
5963             }
5964 0         0 }
5965 0         0 elsif ($char[$i] eq '\u') {
5966             $char[$i] = '@{[Elatin5::ucfirst qq<';
5967             $left_e++;
5968 0         0 }
5969 0         0 elsif ($char[$i] eq '\l') {
5970             $char[$i] = '@{[Elatin5::lcfirst qq<';
5971             $left_e++;
5972 0         0 }
5973 1         3 elsif ($char[$i] eq '\U') {
5974             $char[$i] = '@{[Elatin5::uc qq<';
5975             $left_e++;
5976 1         5 }
5977 1         2 elsif ($char[$i] eq '\L') {
5978             $char[$i] = '@{[Elatin5::lc qq<';
5979             $left_e++;
5980 1         4 }
5981 18         34 elsif ($char[$i] eq '\F') {
5982             $char[$i] = '@{[Elatin5::fc qq<';
5983             $left_e++;
5984 18         58 }
5985 1         3 elsif ($char[$i] eq '\Q') {
5986             $char[$i] = '@{[CORE::quotemeta qq<';
5987             $left_e++;
5988 1 50       3 }
5989 21         44 elsif ($char[$i] eq '\E') {
5990 21         30 if ($right_e < $left_e) {
5991             $char[$i] = '>]}';
5992             $right_e++;
5993 21         42 }
5994             else {
5995             $char[$i] = '';
5996             }
5997 0         0 }
5998 0 0       0 elsif ($char[$i] eq '\Q') {
5999 0         0 while (1) {
6000             if (++$i > $#char) {
6001 0 0       0 last;
6002 0         0 }
6003             if ($char[$i] eq '\E') {
6004             last;
6005             }
6006             }
6007             }
6008             elsif ($char[$i] eq '\E') {
6009             }
6010              
6011 0 0       0 # $0 --> $0
6012 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6013             if ($ignorecase) {
6014             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6015             }
6016 0 0       0 }
6017 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6018             if ($ignorecase) {
6019             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6020             }
6021             }
6022              
6023             # $$ --> $$
6024             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6025             }
6026              
6027             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6028 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6029 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6030 0         0 $char[$i] = e_capture($1);
6031             if ($ignorecase) {
6032             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6033             }
6034 0         0 }
6035 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6036 0         0 $char[$i] = e_capture($1);
6037             if ($ignorecase) {
6038             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6039             }
6040             }
6041              
6042 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6043 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) {
6044 0         0 $char[$i] = e_capture($1.'->'.$2);
6045             if ($ignorecase) {
6046             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6047             }
6048             }
6049              
6050 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6051 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) {
6052 0         0 $char[$i] = e_capture($1.'->'.$2);
6053             if ($ignorecase) {
6054             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6055             }
6056             }
6057              
6058 0         0 # $$foo
6059 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6060 0         0 $char[$i] = e_capture($1);
6061             if ($ignorecase) {
6062             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6063             }
6064             }
6065              
6066 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
6067 8         22 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6068             if ($ignorecase) {
6069             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
6070 0         0 }
6071             else {
6072             $char[$i] = '@{[Elatin5::PREMATCH()]}';
6073             }
6074             }
6075              
6076 8 50       25 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
6077 8         74 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6078             if ($ignorecase) {
6079             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
6080 0         0 }
6081             else {
6082             $char[$i] = '@{[Elatin5::MATCH()]}';
6083             }
6084             }
6085              
6086 8 50       27 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
6087 6         16 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6088             if ($ignorecase) {
6089             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
6090 0         0 }
6091             else {
6092             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
6093             }
6094             }
6095              
6096 6 0       18 # ${ foo }
6097 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) {
6098             if ($ignorecase) {
6099             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6100             }
6101             }
6102              
6103 0         0 # ${ ... }
6104 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6105 0         0 $char[$i] = e_capture($1);
6106             if ($ignorecase) {
6107             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6108             }
6109             }
6110              
6111 0         0 # $scalar or @array
6112 21 100       53 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6113 21         108 $char[$i] = e_string($char[$i]);
6114             if ($ignorecase) {
6115             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6116             }
6117             }
6118              
6119 11 100 33     34 # quote character before ? + * {
    50          
6120             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6121             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6122 138         965 }
6123 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6124 0         0 my $char = $char[$i-1];
6125             if ($char[$i] eq '{') {
6126             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6127 0         0 }
6128             else {
6129             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6130             }
6131 0         0 }
6132             else {
6133             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6134             }
6135             }
6136             }
6137 127         488  
6138 642 50       1322 # make regexp string
6139 642 0 0     1312 $modifier =~ tr/i//d;
6140 0         0 if ($left_e > $right_e) {
6141             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6142             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6143 0         0 }
6144             else {
6145             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6146 0 50 33     0 }
6147 642         3231 }
6148             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6149             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6150 0         0 }
6151             else {
6152             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6153             }
6154             }
6155              
6156             #
6157             # double quote stuff
6158 642     180 0 5119 #
6159             sub qq_stuff {
6160             my($delimiter,$end_delimiter,$stuff) = @_;
6161 180 100       274  
6162 180         341 # scalar variable or array variable
6163             if ($stuff =~ /\A [\$\@] /oxms) {
6164             return $stuff;
6165             }
6166 100         311  
  80         170  
6167 80         212 # quote by delimiter
6168 80 50       195 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6169 80 50       119 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6170 80 50       130 next if $char eq $delimiter;
6171 80         134 next if $char eq $end_delimiter;
6172             if (not $octet{$char}) {
6173             return join '', 'qq', $char, $stuff, $char;
6174 80         290 }
6175             }
6176             return join '', 'qq', '<', $stuff, '>';
6177             }
6178              
6179             #
6180             # escape regexp (m'', qr'', and m''b, qr''b)
6181 0     10 0 0 #
6182 10   50     53 sub e_qr_q {
6183             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6184 10         56 $modifier ||= '';
6185 10 50       17  
6186 10         25 $modifier =~ tr/p//d;
6187 0         0 if ($modifier =~ /([adlu])/oxms) {
6188 0 0       0 my $line = 0;
6189 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6190 0         0 if ($filename ne __FILE__) {
6191             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6192             last;
6193 0         0 }
6194             }
6195             die qq{Unsupported modifier "$1" used at line $line.\n};
6196 0         0 }
6197              
6198             $slash = 'div';
6199 10 100       14  
    50          
6200 10         27 # literal null string pattern
6201 8         9 if ($string eq '') {
6202 8         10 $modifier =~ tr/bB//d;
6203             $modifier =~ tr/i//d;
6204             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6205             }
6206              
6207 8         43 # with /b /B modifier
6208             elsif ($modifier =~ tr/bB//d) {
6209             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6210             }
6211              
6212 0         0 # without /b /B modifier
6213             else {
6214             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6215             }
6216             }
6217              
6218             #
6219             # escape regexp (m'', qr'')
6220 2     2 0 9 #
6221             sub e_qr_qt {
6222 2 50       7 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6223              
6224             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6225 2         54  
6226             # split regexp
6227             my @char = $string =~ /\G((?>
6228             [^\\\[\$\@\/] |
6229             [\x00-\xFF] |
6230             \[\^ |
6231             \[\: (?>[a-z]+) \:\] |
6232             \[\:\^ (?>[a-z]+) \:\] |
6233             [\$\@\/] |
6234             \\ (?:$q_char) |
6235             (?:$q_char)
6236             ))/oxmsg;
6237 2         119  
6238 2 50 33     15 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6239             for (my $i=0; $i <= $#char; $i++) {
6240             if (0) {
6241             }
6242 2         21  
6243 0         0 # open character class [...]
6244 0 0       0 elsif ($char[$i] eq '[') {
6245 0         0 my $left = $i;
6246             if ($char[$i+1] eq ']') {
6247 0         0 $i++;
6248 0 0       0 }
6249 0         0 while (1) {
6250             if (++$i > $#char) {
6251 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6252 0         0 }
6253             if ($char[$i] eq ']') {
6254             my $right = $i;
6255 0         0  
6256             # [...]
6257 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6258 0         0  
6259             $i = $left;
6260             last;
6261             }
6262             }
6263             }
6264              
6265 0         0 # open character class [^...]
6266 0 0       0 elsif ($char[$i] eq '[^') {
6267 0         0 my $left = $i;
6268             if ($char[$i+1] eq ']') {
6269 0         0 $i++;
6270 0 0       0 }
6271 0         0 while (1) {
6272             if (++$i > $#char) {
6273 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6274 0         0 }
6275             if ($char[$i] eq ']') {
6276             my $right = $i;
6277 0         0  
6278             # [^...]
6279 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6280 0         0  
6281             $i = $left;
6282             last;
6283             }
6284             }
6285             }
6286              
6287 0         0 # escape $ @ / and \
6288             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6289             $char[$i] = '\\' . $char[$i];
6290             }
6291              
6292 0         0 # rewrite character class or escape character
6293             elsif (my $char = character_class($char[$i],$modifier)) {
6294             $char[$i] = $char;
6295             }
6296              
6297 0 0       0 # /i modifier
6298 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6299             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6300             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6301 0         0 }
6302             else {
6303             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6304             }
6305             }
6306              
6307 0 0       0 # quote character before ? + * {
6308             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6309             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6310 0         0 }
6311             else {
6312             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6313             }
6314             }
6315 0         0 }
6316 2         5  
6317             $delimiter = '/';
6318 2         5 $end_delimiter = '/';
6319 2         4  
6320             $modifier =~ tr/i//d;
6321             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6322             }
6323              
6324             #
6325             # escape regexp (m''b, qr''b)
6326 2     0 0 17 #
6327             sub e_qr_qb {
6328             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6329 0         0  
6330             # split regexp
6331             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6332 0         0  
6333 0 0       0 # unescape character
    0          
6334             for (my $i=0; $i <= $#char; $i++) {
6335             if (0) {
6336             }
6337 0         0  
6338             # remain \\
6339             elsif ($char[$i] eq '\\\\') {
6340             }
6341              
6342 0         0 # escape $ @ / and \
6343             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6344             $char[$i] = '\\' . $char[$i];
6345             }
6346 0         0 }
6347 0         0  
6348 0         0 $delimiter = '/';
6349             $end_delimiter = '/';
6350             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6351             }
6352              
6353             #
6354             # escape regexp (s/here//)
6355 0     76 0 0 #
6356 76   100     224 sub e_s1 {
6357             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6358 76         396 $modifier ||= '';
6359 76 50       115  
6360 76         281 $modifier =~ tr/p//d;
6361 0         0 if ($modifier =~ /([adlu])/oxms) {
6362 0 0       0 my $line = 0;
6363 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6364 0         0 if ($filename ne __FILE__) {
6365             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6366             last;
6367 0         0 }
6368             }
6369             die qq{Unsupported modifier "$1" used at line $line.\n};
6370 0         0 }
6371              
6372             $slash = 'div';
6373 76 100       145  
    50          
6374 76         336 # literal null string pattern
6375 8         15 if ($string eq '') {
6376 8         10 $modifier =~ tr/bB//d;
6377             $modifier =~ tr/i//d;
6378             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6379             }
6380              
6381             # /b /B modifier
6382             elsif ($modifier =~ tr/bB//d) {
6383 8 0       130  
6384 0         0 # choice again delimiter
6385 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6386 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6387 0         0 my %octet = map {$_ => 1} @char;
6388 0         0 if (not $octet{')'}) {
6389             $delimiter = '(';
6390             $end_delimiter = ')';
6391 0         0 }
6392 0         0 elsif (not $octet{'}'}) {
6393             $delimiter = '{';
6394             $end_delimiter = '}';
6395 0         0 }
6396 0         0 elsif (not $octet{']'}) {
6397             $delimiter = '[';
6398             $end_delimiter = ']';
6399 0         0 }
6400 0         0 elsif (not $octet{'>'}) {
6401             $delimiter = '<';
6402             $end_delimiter = '>';
6403 0         0 }
6404 0 0       0 else {
6405 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6406 0         0 if (not $octet{$char}) {
6407 0         0 $delimiter = $char;
6408             $end_delimiter = $char;
6409             last;
6410             }
6411             }
6412             }
6413 0         0 }
6414 0         0  
6415             my $prematch = '';
6416             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6417 0 100       0 }
6418 68         221  
6419             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6420             my $metachar = qr/[\@\\|[\]{^]/oxms;
6421 68         294  
6422             # split regexp
6423             my @char = $string =~ /\G((?>
6424             [^\\\$\@\[\(] |
6425             \\ (?>[1-9][0-9]*) |
6426             \\g (?>\s*) (?>[1-9][0-9]*) |
6427             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6428             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6429             \\x (?>[0-9A-Fa-f]{1,2}) |
6430             \\ (?>[0-7]{2,3}) |
6431             \\c [\x40-\x5F] |
6432             \\x\{ (?>[0-9A-Fa-f]+) \} |
6433             \\o\{ (?>[0-7]+) \} |
6434             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6435             \\ $q_char |
6436             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6437             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6438             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6439             [\$\@] $qq_variable |
6440             \$ (?>\s* [0-9]+) |
6441             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6442             \$ \$ (?![\w\{]) |
6443             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6444             \[\^ |
6445             \[\: (?>[a-z]+) :\] |
6446             \[\:\^ (?>[a-z]+) :\] |
6447             \(\? |
6448             $q_char
6449             ))/oxmsg;
6450 68 50       17714  
6451 68         766 # choice again delimiter
  0         0  
6452 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6453 0         0 my %octet = map {$_ => 1} @char;
6454 0         0 if (not $octet{')'}) {
6455             $delimiter = '(';
6456             $end_delimiter = ')';
6457 0         0 }
6458 0         0 elsif (not $octet{'}'}) {
6459             $delimiter = '{';
6460             $end_delimiter = '}';
6461 0         0 }
6462 0         0 elsif (not $octet{']'}) {
6463             $delimiter = '[';
6464             $end_delimiter = ']';
6465 0         0 }
6466 0         0 elsif (not $octet{'>'}) {
6467             $delimiter = '<';
6468             $end_delimiter = '>';
6469 0         0 }
6470 0 0       0 else {
6471 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6472 0         0 if (not $octet{$char}) {
6473 0         0 $delimiter = $char;
6474             $end_delimiter = $char;
6475             last;
6476             }
6477             }
6478             }
6479             }
6480 0         0  
  68         155  
6481             # count '('
6482 253         432 my $parens = grep { $_ eq '(' } @char;
6483 68         116  
6484 68         114 my $left_e = 0;
6485             my $right_e = 0;
6486             for (my $i=0; $i <= $#char; $i++) {
6487 68 50 33     211  
    50 33        
    100          
    100          
    50          
    50          
6488 195         1390 # "\L\u" --> "\u\L"
6489             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6490             @char[$i,$i+1] = @char[$i+1,$i];
6491             }
6492              
6493 0         0 # "\U\l" --> "\l\U"
6494             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6495             @char[$i,$i+1] = @char[$i+1,$i];
6496             }
6497              
6498 0         0 # octal escape sequence
6499             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6500             $char[$i] = Elatin5::octchr($1);
6501             }
6502              
6503 1         4 # hexadecimal escape sequence
6504             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6505             $char[$i] = Elatin5::hexchr($1);
6506             }
6507              
6508             # \b{...} --> b\{...}
6509             # \B{...} --> B\{...}
6510             # \N{CHARNAME} --> N\{CHARNAME}
6511             # \p{PROPERTY} --> p\{PROPERTY}
6512 1         5 # \P{PROPERTY} --> P\{PROPERTY}
6513             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6514             $char[$i] = $1 . '\\' . $2;
6515             }
6516              
6517 0         0 # \p, \P, \X --> p, P, X
6518             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6519             $char[$i] = $1;
6520 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          
6521              
6522             if (0) {
6523             }
6524 195         1004  
6525 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6526 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6527             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)) {
6528             $char[$i] .= join '', splice @char, $i+1, 3;
6529 0         0 }
6530             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)) {
6531             $char[$i] .= join '', splice @char, $i+1, 2;
6532 0         0 }
6533             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)) {
6534             $char[$i] .= join '', splice @char, $i+1, 1;
6535             }
6536             }
6537              
6538 0         0 # open character class [...]
6539 13 50       24 elsif ($char[$i] eq '[') {
6540 13         46 my $left = $i;
6541             if ($char[$i+1] eq ']') {
6542 0         0 $i++;
6543 13 50       18 }
6544 58         90 while (1) {
6545             if (++$i > $#char) {
6546 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6547 58         136 }
6548             if ($char[$i] eq ']') {
6549             my $right = $i;
6550 13 50       21  
6551 13         77 # [...]
  0         0  
6552             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6553             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6554 0         0 }
6555             else {
6556             splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6557 13         46 }
6558 13         22  
6559             $i = $left;
6560             last;
6561             }
6562             }
6563             }
6564              
6565 13         35 # open character class [^...]
6566 0 0       0 elsif ($char[$i] eq '[^') {
6567 0         0 my $left = $i;
6568             if ($char[$i+1] eq ']') {
6569 0         0 $i++;
6570 0 0       0 }
6571 0         0 while (1) {
6572             if (++$i > $#char) {
6573 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6574 0         0 }
6575             if ($char[$i] eq ']') {
6576             my $right = $i;
6577 0 0       0  
6578 0         0 # [^...]
  0         0  
6579             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6580             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6581 0         0 }
6582             else {
6583             splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6584 0         0 }
6585 0         0  
6586             $i = $left;
6587             last;
6588             }
6589             }
6590             }
6591              
6592 0         0 # rewrite character class or escape character
6593             elsif (my $char = character_class($char[$i],$modifier)) {
6594             $char[$i] = $char;
6595             }
6596              
6597 7 50       15 # /i modifier
6598 3         4 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6599             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6600             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6601 3         4 }
6602             else {
6603             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6604             }
6605             }
6606              
6607 0 0       0 # \u \l \U \L \F \Q \E
6608 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6609             if ($right_e < $left_e) {
6610             $char[$i] = '\\' . $char[$i];
6611             }
6612 0         0 }
6613 0         0 elsif ($char[$i] eq '\u') {
6614             $char[$i] = '@{[Elatin5::ucfirst qq<';
6615             $left_e++;
6616 0         0 }
6617 0         0 elsif ($char[$i] eq '\l') {
6618             $char[$i] = '@{[Elatin5::lcfirst qq<';
6619             $left_e++;
6620 0         0 }
6621 0         0 elsif ($char[$i] eq '\U') {
6622             $char[$i] = '@{[Elatin5::uc qq<';
6623             $left_e++;
6624 0         0 }
6625 0         0 elsif ($char[$i] eq '\L') {
6626             $char[$i] = '@{[Elatin5::lc qq<';
6627             $left_e++;
6628 0         0 }
6629 0         0 elsif ($char[$i] eq '\F') {
6630             $char[$i] = '@{[Elatin5::fc qq<';
6631             $left_e++;
6632 0         0 }
6633 0         0 elsif ($char[$i] eq '\Q') {
6634             $char[$i] = '@{[CORE::quotemeta qq<';
6635             $left_e++;
6636 0 0       0 }
6637 0         0 elsif ($char[$i] eq '\E') {
6638 0         0 if ($right_e < $left_e) {
6639             $char[$i] = '>]}';
6640             $right_e++;
6641 0         0 }
6642             else {
6643             $char[$i] = '';
6644             }
6645 0         0 }
6646 0 0       0 elsif ($char[$i] eq '\Q') {
6647 0         0 while (1) {
6648             if (++$i > $#char) {
6649 0 0       0 last;
6650 0         0 }
6651             if ($char[$i] eq '\E') {
6652             last;
6653             }
6654             }
6655             }
6656             elsif ($char[$i] eq '\E') {
6657             }
6658              
6659             # \0 --> \0
6660             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6661             }
6662              
6663             # \g{N}, \g{-N}
6664              
6665             # P.108 Using Simple Patterns
6666             # in Chapter 7: In the World of Regular Expressions
6667             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6668              
6669             # P.221 Capturing
6670             # in Chapter 5: Pattern Matching
6671             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6672              
6673             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6674             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6675             }
6676              
6677             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6678             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6679             }
6680              
6681             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6682             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6683             }
6684              
6685             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6686             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6687             }
6688              
6689 0 0       0 # $0 --> $0
6690 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6691             if ($ignorecase) {
6692             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6693             }
6694 0 0       0 }
6695 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6696             if ($ignorecase) {
6697             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6698             }
6699             }
6700              
6701             # $$ --> $$
6702             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6703             }
6704              
6705             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6706 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6707 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6708 0         0 $char[$i] = e_capture($1);
6709             if ($ignorecase) {
6710             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6711             }
6712 0         0 }
6713 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6714 0         0 $char[$i] = e_capture($1);
6715             if ($ignorecase) {
6716             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6717             }
6718             }
6719              
6720 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6721 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) {
6722 0         0 $char[$i] = e_capture($1.'->'.$2);
6723             if ($ignorecase) {
6724             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6725             }
6726             }
6727              
6728 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6729 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) {
6730 0         0 $char[$i] = e_capture($1.'->'.$2);
6731             if ($ignorecase) {
6732             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6733             }
6734             }
6735              
6736 0         0 # $$foo
6737 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6738 0         0 $char[$i] = e_capture($1);
6739             if ($ignorecase) {
6740             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6741             }
6742             }
6743              
6744 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
6745 4         13 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6746             if ($ignorecase) {
6747             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
6748 0         0 }
6749             else {
6750             $char[$i] = '@{[Elatin5::PREMATCH()]}';
6751             }
6752             }
6753              
6754 4 50       14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
6755 4         14 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6756             if ($ignorecase) {
6757             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
6758 0         0 }
6759             else {
6760             $char[$i] = '@{[Elatin5::MATCH()]}';
6761             }
6762             }
6763              
6764 4 50       16 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
6765 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6766             if ($ignorecase) {
6767             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
6768 0         0 }
6769             else {
6770             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
6771             }
6772             }
6773              
6774 3 0       11 # ${ foo }
6775 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) {
6776             if ($ignorecase) {
6777             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6778             }
6779             }
6780              
6781 0         0 # ${ ... }
6782 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6783 0         0 $char[$i] = e_capture($1);
6784             if ($ignorecase) {
6785             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6786             }
6787             }
6788              
6789 0         0 # $scalar or @array
6790 4 50       21 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6791 4         20 $char[$i] = e_string($char[$i]);
6792             if ($ignorecase) {
6793             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6794             }
6795             }
6796              
6797 0 50       0 # quote character before ? + * {
6798             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6799             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6800 13         61 }
6801             else {
6802             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6803             }
6804             }
6805             }
6806 13         59  
6807 68         163 # make regexp string
6808 68 50       113 my $prematch = '';
6809 68         179 $modifier =~ tr/i//d;
6810             if ($left_e > $right_e) {
6811 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6812             }
6813             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6814             }
6815              
6816             #
6817             # escape regexp (s'here'' or s'here''b)
6818 68     21 0 749 #
6819 21   100     148 sub e_s1_q {
6820             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6821 21         80 $modifier ||= '';
6822 21 50       31  
6823 21         45 $modifier =~ tr/p//d;
6824 0         0 if ($modifier =~ /([adlu])/oxms) {
6825 0 0       0 my $line = 0;
6826 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6827 0         0 if ($filename ne __FILE__) {
6828             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6829             last;
6830 0         0 }
6831             }
6832             die qq{Unsupported modifier "$1" used at line $line.\n};
6833 0         0 }
6834              
6835             $slash = 'div';
6836 21 100       38  
    50          
6837 21         55 # literal null string pattern
6838 8         12 if ($string eq '') {
6839 8         12 $modifier =~ tr/bB//d;
6840             $modifier =~ tr/i//d;
6841             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6842             }
6843              
6844 8         62 # with /b /B modifier
6845             elsif ($modifier =~ tr/bB//d) {
6846             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6847             }
6848              
6849 0         0 # without /b /B modifier
6850             else {
6851             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6852             }
6853             }
6854              
6855             #
6856             # escape regexp (s'here'')
6857 13     13 0 32 #
6858             sub e_s1_qt {
6859 13 50       39 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6860              
6861             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6862 13         26  
6863             # split regexp
6864             my @char = $string =~ /\G((?>
6865             [^\\\[\$\@\/] |
6866             [\x00-\xFF] |
6867             \[\^ |
6868             \[\: (?>[a-z]+) \:\] |
6869             \[\:\^ (?>[a-z]+) \:\] |
6870             [\$\@\/] |
6871             \\ (?:$q_char) |
6872             (?:$q_char)
6873             ))/oxmsg;
6874 13         215  
6875 13 50 33     43 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6876             for (my $i=0; $i <= $#char; $i++) {
6877             if (0) {
6878             }
6879 25         103  
6880 0         0 # open character class [...]
6881 0 0       0 elsif ($char[$i] eq '[') {
6882 0         0 my $left = $i;
6883             if ($char[$i+1] eq ']') {
6884 0         0 $i++;
6885 0 0       0 }
6886 0         0 while (1) {
6887             if (++$i > $#char) {
6888 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6889 0         0 }
6890             if ($char[$i] eq ']') {
6891             my $right = $i;
6892 0         0  
6893             # [...]
6894 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6895 0         0  
6896             $i = $left;
6897             last;
6898             }
6899             }
6900             }
6901              
6902 0         0 # open character class [^...]
6903 0 0       0 elsif ($char[$i] eq '[^') {
6904 0         0 my $left = $i;
6905             if ($char[$i+1] eq ']') {
6906 0         0 $i++;
6907 0 0       0 }
6908 0         0 while (1) {
6909             if (++$i > $#char) {
6910 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6911 0         0 }
6912             if ($char[$i] eq ']') {
6913             my $right = $i;
6914 0         0  
6915             # [^...]
6916 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6917 0         0  
6918             $i = $left;
6919             last;
6920             }
6921             }
6922             }
6923              
6924 0         0 # escape $ @ / and \
6925             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6926             $char[$i] = '\\' . $char[$i];
6927             }
6928              
6929 0         0 # rewrite character class or escape character
6930             elsif (my $char = character_class($char[$i],$modifier)) {
6931             $char[$i] = $char;
6932             }
6933              
6934 6 0       12 # /i modifier
6935 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6936             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6937             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6938 0         0 }
6939             else {
6940             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6941             }
6942             }
6943              
6944 0 0       0 # quote character before ? + * {
6945             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6946             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6947 0         0 }
6948             else {
6949             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6950             }
6951             }
6952 0         0 }
6953 13         24  
6954 13         17 $modifier =~ tr/i//d;
6955 13         17 $delimiter = '/';
6956 13         18 $end_delimiter = '/';
6957             my $prematch = '';
6958             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6959             }
6960              
6961             #
6962             # escape regexp (s'here''b)
6963 13     0 0 102 #
6964             sub e_s1_qb {
6965             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6966 0         0  
6967             # split regexp
6968             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6969 0         0  
6970 0 0       0 # unescape character
    0          
6971             for (my $i=0; $i <= $#char; $i++) {
6972             if (0) {
6973             }
6974 0         0  
6975             # remain \\
6976             elsif ($char[$i] eq '\\\\') {
6977             }
6978              
6979 0         0 # escape $ @ / and \
6980             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6981             $char[$i] = '\\' . $char[$i];
6982             }
6983 0         0 }
6984 0         0  
6985 0         0 $delimiter = '/';
6986 0         0 $end_delimiter = '/';
6987             my $prematch = '';
6988             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6989             }
6990              
6991             #
6992             # escape regexp (s''here')
6993 0     16 0 0 #
6994             sub e_s2_q {
6995 16         70 my($ope,$delimiter,$end_delimiter,$string) = @_;
6996              
6997 16         25 $slash = 'div';
6998 16         102  
6999 16 100       107 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7000             for (my $i=0; $i <= $#char; $i++) {
7001             if (0) {
7002             }
7003 9         30  
7004             # not escape \\
7005             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7006             }
7007              
7008 0         0 # escape $ @ / and \
7009             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7010             $char[$i] = '\\' . $char[$i];
7011             }
7012 5         14 }
7013              
7014             return join '', $ope, $delimiter, @char, $end_delimiter;
7015             }
7016              
7017             #
7018             # escape regexp (s/here/and here/modifier)
7019 16     97 0 53 #
7020 97   100     868 sub e_sub {
7021             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7022 97         565 $modifier ||= '';
7023 97 50       194  
7024 97         282 $modifier =~ tr/p//d;
7025 0         0 if ($modifier =~ /([adlu])/oxms) {
7026 0 0       0 my $line = 0;
7027 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7028 0         0 if ($filename ne __FILE__) {
7029             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7030             last;
7031 0         0 }
7032             }
7033             die qq{Unsupported modifier "$1" used at line $line.\n};
7034 0 100       0 }
7035 97         254  
7036 36         49 if ($variable eq '') {
7037             $variable = '$_';
7038             $bind_operator = ' =~ ';
7039 36         46 }
7040              
7041             $slash = 'div';
7042              
7043             # P.128 Start of match (or end of previous match): \G
7044             # P.130 Advanced Use of \G with Perl
7045             # in Chapter 3: Overview of Regular Expression Features and Flavors
7046             # P.312 Iterative Matching: Scalar Context, with /g
7047             # in Chapter 7: Perl
7048             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7049              
7050             # P.181 Where You Left Off: The \G Assertion
7051             # in Chapter 5: Pattern Matching
7052             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7053              
7054             # P.220 Where You Left Off: The \G Assertion
7055             # in Chapter 5: Pattern Matching
7056 97         167 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7057 97         168  
7058             my $e_modifier = $modifier =~ tr/e//d;
7059 97         209 my $r_modifier = $modifier =~ tr/r//d;
7060 97 50       153  
7061 97         322 my $my = '';
7062 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7063 0         0 $my = $variable;
7064             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7065             $variable =~ s/ = .+ \z//oxms;
7066 0         0 }
7067 97         250  
7068             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7069             $variable_basename =~ s/ \s+ \z//oxms;
7070 97         180  
7071 97 100       149 # quote replacement string
7072 97         236 my $e_replacement = '';
7073 17         33 if ($e_modifier >= 1) {
7074             $e_replacement = e_qq('', '', '', $replacement);
7075             $e_modifier--;
7076 17 100       26 }
7077 80         209 else {
7078             if ($delimiter2 eq "'") {
7079             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7080 16         45 }
7081             else {
7082             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7083             }
7084 64         224 }
7085              
7086             my $sub = '';
7087 97 100       183  
7088 97 100       301 # with /r
7089             if ($r_modifier) {
7090             if (0) {
7091             }
7092 8         61  
7093 0 50       0 # s///gr without multibyte anchoring
7094             elsif ($modifier =~ /g/oxms) {
7095             $sub = sprintf(
7096             # 1 2 3 4 5
7097             q,
7098              
7099             $variable, # 1
7100             ($delimiter1 eq "'") ? # 2
7101             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7102             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7103             $s_matched, # 3
7104             $e_replacement, # 4
7105             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 5
7106             );
7107             }
7108              
7109             # s///r
7110 4         18 else {
7111              
7112 4 50       6 my $prematch = q{$`};
7113              
7114             $sub = sprintf(
7115             # 1 2 3 4 5 6 7
7116             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin5::re_r=%s; %s"%s$Elatin5::re_r$'" } : %s>,
7117              
7118             $variable, # 1
7119             ($delimiter1 eq "'") ? # 2
7120             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7121             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7122             $s_matched, # 3
7123             $e_replacement, # 4
7124             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 5
7125             $prematch, # 6
7126             $variable, # 7
7127             );
7128             }
7129 4 50       21  
7130 8         27 # $var !~ s///r doesn't make sense
7131             if ($bind_operator =~ / !~ /oxms) {
7132             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7133             }
7134             }
7135              
7136 0 100       0 # without /r
7137             else {
7138             if (0) {
7139             }
7140 89         255  
7141 0 100       0 # s///g without multibyte anchoring
    100          
7142             elsif ($modifier =~ /g/oxms) {
7143             $sub = sprintf(
7144             # 1 2 3 4 5 6 7 8
7145             q,
7146              
7147             $variable, # 1
7148             ($delimiter1 eq "'") ? # 2
7149             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7150             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7151             $s_matched, # 3
7152             $e_replacement, # 4
7153             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 5
7154             $variable, # 6
7155             $variable, # 7
7156             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7157             );
7158             }
7159              
7160             # s///
7161 22         89 else {
7162              
7163 67 100       170 my $prematch = q{$`};
    100          
7164              
7165             $sub = sprintf(
7166              
7167             ($bind_operator =~ / =~ /oxms) ?
7168              
7169             # 1 2 3 4 5 6 7 8
7170             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin5::re_r=%s; %s%s="%s$Elatin5::re_r$'"; 1 } : undef> :
7171              
7172             # 1 2 3 4 5 6 7 8
7173             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin5::re_r=%s; %s%s="%s$Elatin5::re_r$'"; undef }>,
7174              
7175             $variable, # 1
7176             $bind_operator, # 2
7177             ($delimiter1 eq "'") ? # 3
7178             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7179             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7180             $s_matched, # 4
7181             $e_replacement, # 5
7182             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 6
7183             $variable, # 7
7184             $prematch, # 8
7185             );
7186             }
7187             }
7188 67 50       406  
7189 97         294 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7190             if ($my ne '') {
7191             $sub = "($my, $sub)[1]";
7192             }
7193 0         0  
7194 97         154 # clear s/// variable
7195             $sub_variable = '';
7196 97         219 $bind_operator = '';
7197              
7198             return $sub;
7199             }
7200              
7201             #
7202             # escape regexp of split qr//
7203 97     74 0 800 #
7204 74   100     338 sub e_split {
7205             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7206 74         333 $modifier ||= '';
7207 74 50       140  
7208 74         187 $modifier =~ tr/p//d;
7209 0         0 if ($modifier =~ /([adlu])/oxms) {
7210 0 0       0 my $line = 0;
7211 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7212 0         0 if ($filename ne __FILE__) {
7213             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7214             last;
7215 0         0 }
7216             }
7217             die qq{Unsupported modifier "$1" used at line $line.\n};
7218 0         0 }
7219              
7220             $slash = 'div';
7221 74 50       133  
7222 74         146 # /b /B modifier
7223             if ($modifier =~ tr/bB//d) {
7224             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7225 0 50       0 }
7226 74         172  
7227             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7228             my $metachar = qr/[\@\\|[\]{^]/oxms;
7229 74         272  
7230             # split regexp
7231             my @char = $string =~ /\G((?>
7232             [^\\\$\@\[\(] |
7233             \\x (?>[0-9A-Fa-f]{1,2}) |
7234             \\ (?>[0-7]{2,3}) |
7235             \\c [\x40-\x5F] |
7236             \\x\{ (?>[0-9A-Fa-f]+) \} |
7237             \\o\{ (?>[0-7]+) \} |
7238             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7239             \\ $q_char |
7240             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7241             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7242             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7243             [\$\@] $qq_variable |
7244             \$ (?>\s* [0-9]+) |
7245             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7246             \$ \$ (?![\w\{]) |
7247             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7248             \[\^ |
7249             \[\: (?>[a-z]+) :\] |
7250             \[\:\^ (?>[a-z]+) :\] |
7251             \(\? |
7252             $q_char
7253 74         8825 ))/oxmsg;
7254 74         238  
7255 74         120 my $left_e = 0;
7256             my $right_e = 0;
7257             for (my $i=0; $i <= $#char; $i++) {
7258 74 50 33     358  
    50 33        
    100          
    100          
    50          
    50          
7259 249         1247 # "\L\u" --> "\u\L"
7260             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7261             @char[$i,$i+1] = @char[$i+1,$i];
7262             }
7263              
7264 0         0 # "\U\l" --> "\l\U"
7265             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7266             @char[$i,$i+1] = @char[$i+1,$i];
7267             }
7268              
7269 0         0 # octal escape sequence
7270             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7271             $char[$i] = Elatin5::octchr($1);
7272             }
7273              
7274 1         4 # hexadecimal escape sequence
7275             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7276             $char[$i] = Elatin5::hexchr($1);
7277             }
7278              
7279             # \b{...} --> b\{...}
7280             # \B{...} --> B\{...}
7281             # \N{CHARNAME} --> N\{CHARNAME}
7282             # \p{PROPERTY} --> p\{PROPERTY}
7283 1         4 # \P{PROPERTY} --> P\{PROPERTY}
7284             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7285             $char[$i] = $1 . '\\' . $2;
7286             }
7287              
7288 0         0 # \p, \P, \X --> p, P, X
7289             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7290             $char[$i] = $1;
7291 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          
7292              
7293             if (0) {
7294             }
7295 249         841  
7296 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7297 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7298             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)) {
7299             $char[$i] .= join '', splice @char, $i+1, 3;
7300 0         0 }
7301             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)) {
7302             $char[$i] .= join '', splice @char, $i+1, 2;
7303 0         0 }
7304             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)) {
7305             $char[$i] .= join '', splice @char, $i+1, 1;
7306             }
7307             }
7308              
7309 0         0 # open character class [...]
7310 3 50       6 elsif ($char[$i] eq '[') {
7311 3         6 my $left = $i;
7312             if ($char[$i+1] eq ']') {
7313 0         0 $i++;
7314 3 50       4 }
7315 7         11 while (1) {
7316             if (++$i > $#char) {
7317 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7318 7         23 }
7319             if ($char[$i] eq ']') {
7320             my $right = $i;
7321 3 50       5  
7322 3         13 # [...]
  0         0  
7323             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7324             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7325 0         0 }
7326             else {
7327             splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
7328 3         11 }
7329 3         5  
7330             $i = $left;
7331             last;
7332             }
7333             }
7334             }
7335              
7336 3         7 # open character class [^...]
7337 0 0       0 elsif ($char[$i] eq '[^') {
7338 0         0 my $left = $i;
7339             if ($char[$i+1] eq ']') {
7340 0         0 $i++;
7341 0 0       0 }
7342 0         0 while (1) {
7343             if (++$i > $#char) {
7344 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7345 0         0 }
7346             if ($char[$i] eq ']') {
7347             my $right = $i;
7348 0 0       0  
7349 0         0 # [^...]
  0         0  
7350             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7351             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7352 0         0 }
7353             else {
7354             splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7355 0         0 }
7356 0         0  
7357             $i = $left;
7358             last;
7359             }
7360             }
7361             }
7362              
7363 0         0 # rewrite character class or escape character
7364             elsif (my $char = character_class($char[$i],$modifier)) {
7365             $char[$i] = $char;
7366             }
7367              
7368             # P.794 29.2.161. split
7369             # in Chapter 29: Functions
7370             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7371              
7372             # P.951 split
7373             # in Chapter 27: Functions
7374             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7375              
7376             # said "The //m modifier is assumed when you split on the pattern /^/",
7377             # but perl5.008 is not so. Therefore, this software adds //m.
7378             # (and so on)
7379              
7380 1         3 # split(m/^/) --> split(m/^/m)
7381             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7382             $modifier .= 'm';
7383             }
7384              
7385 7 0       23 # /i modifier
7386 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
7387             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
7388             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
7389 0         0 }
7390             else {
7391             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
7392             }
7393             }
7394              
7395 0 0       0 # \u \l \U \L \F \Q \E
7396 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7397             if ($right_e < $left_e) {
7398             $char[$i] = '\\' . $char[$i];
7399             }
7400 0         0 }
7401 0         0 elsif ($char[$i] eq '\u') {
7402             $char[$i] = '@{[Elatin5::ucfirst qq<';
7403             $left_e++;
7404 0         0 }
7405 0         0 elsif ($char[$i] eq '\l') {
7406             $char[$i] = '@{[Elatin5::lcfirst qq<';
7407             $left_e++;
7408 0         0 }
7409 0         0 elsif ($char[$i] eq '\U') {
7410             $char[$i] = '@{[Elatin5::uc qq<';
7411             $left_e++;
7412 0         0 }
7413 0         0 elsif ($char[$i] eq '\L') {
7414             $char[$i] = '@{[Elatin5::lc qq<';
7415             $left_e++;
7416 0         0 }
7417 0         0 elsif ($char[$i] eq '\F') {
7418             $char[$i] = '@{[Elatin5::fc qq<';
7419             $left_e++;
7420 0         0 }
7421 0         0 elsif ($char[$i] eq '\Q') {
7422             $char[$i] = '@{[CORE::quotemeta qq<';
7423             $left_e++;
7424 0 0       0 }
7425 0         0 elsif ($char[$i] eq '\E') {
7426 0         0 if ($right_e < $left_e) {
7427             $char[$i] = '>]}';
7428             $right_e++;
7429 0         0 }
7430             else {
7431             $char[$i] = '';
7432             }
7433 0         0 }
7434 0 0       0 elsif ($char[$i] eq '\Q') {
7435 0         0 while (1) {
7436             if (++$i > $#char) {
7437 0 0       0 last;
7438 0         0 }
7439             if ($char[$i] eq '\E') {
7440             last;
7441             }
7442             }
7443             }
7444             elsif ($char[$i] eq '\E') {
7445             }
7446              
7447 0 0       0 # $0 --> $0
7448 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7449             if ($ignorecase) {
7450             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7451             }
7452 0 0       0 }
7453 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7454             if ($ignorecase) {
7455             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7456             }
7457             }
7458              
7459             # $$ --> $$
7460             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7461             }
7462              
7463             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7464 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7465 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7466 0         0 $char[$i] = e_capture($1);
7467             if ($ignorecase) {
7468             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7469             }
7470 0         0 }
7471 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7472 0         0 $char[$i] = e_capture($1);
7473             if ($ignorecase) {
7474             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7475             }
7476             }
7477              
7478 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7479 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) {
7480 0         0 $char[$i] = e_capture($1.'->'.$2);
7481             if ($ignorecase) {
7482             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7483             }
7484             }
7485              
7486 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7487 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) {
7488 0         0 $char[$i] = e_capture($1.'->'.$2);
7489             if ($ignorecase) {
7490             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7491             }
7492             }
7493              
7494 0         0 # $$foo
7495 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7496 0         0 $char[$i] = e_capture($1);
7497             if ($ignorecase) {
7498             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7499             }
7500             }
7501              
7502 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
7503 12         34 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7504             if ($ignorecase) {
7505             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
7506 0         0 }
7507             else {
7508             $char[$i] = '@{[Elatin5::PREMATCH()]}';
7509             }
7510             }
7511              
7512 12 50       72 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
7513 12         34 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7514             if ($ignorecase) {
7515             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
7516 0         0 }
7517             else {
7518             $char[$i] = '@{[Elatin5::MATCH()]}';
7519             }
7520             }
7521              
7522 12 50       55 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
7523 9         28 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7524             if ($ignorecase) {
7525             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
7526 0         0 }
7527             else {
7528             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
7529             }
7530             }
7531              
7532 9 0       41 # ${ foo }
7533 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) {
7534             if ($ignorecase) {
7535             $char[$i] = '@{[Elatin5::ignorecase(' . $1 . ')]}';
7536             }
7537             }
7538              
7539 0         0 # ${ ... }
7540 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7541 0         0 $char[$i] = e_capture($1);
7542             if ($ignorecase) {
7543             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7544             }
7545             }
7546              
7547 0         0 # $scalar or @array
7548 3 50       14 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7549 3         13 $char[$i] = e_string($char[$i]);
7550             if ($ignorecase) {
7551             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7552             }
7553             }
7554              
7555 0 50       0 # quote character before ? + * {
7556             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7557             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7558 1         6 }
7559             else {
7560             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7561             }
7562             }
7563             }
7564 0         0  
7565 74 50       210 # make regexp string
7566 74         155 $modifier =~ tr/i//d;
7567             if ($left_e > $right_e) {
7568 0         0 return join '', 'Elatin5::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7569             }
7570             return join '', 'Elatin5::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7571             }
7572              
7573             #
7574             # escape regexp of split qr''
7575 74     0 0 742 #
7576 0   0       sub e_split_q {
7577             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7578 0           $modifier ||= '';
7579 0 0          
7580 0           $modifier =~ tr/p//d;
7581 0           if ($modifier =~ /([adlu])/oxms) {
7582 0 0         my $line = 0;
7583 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7584 0           if ($filename ne __FILE__) {
7585             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7586             last;
7587 0           }
7588             }
7589             die qq{Unsupported modifier "$1" used at line $line.\n};
7590 0           }
7591              
7592             $slash = 'div';
7593 0 0          
7594 0           # /b /B modifier
7595             if ($modifier =~ tr/bB//d) {
7596             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7597 0 0         }
7598              
7599             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7600 0            
7601             # split regexp
7602             my @char = $string =~ /\G((?>
7603             [^\\\[] |
7604             [\x00-\xFF] |
7605             \[\^ |
7606             \[\: (?>[a-z]+) \:\] |
7607             \[\:\^ (?>[a-z]+) \:\] |
7608             \\ (?:$q_char) |
7609             (?:$q_char)
7610             ))/oxmsg;
7611 0            
7612 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7613             for (my $i=0; $i <= $#char; $i++) {
7614             if (0) {
7615             }
7616 0            
7617 0           # open character class [...]
7618 0 0         elsif ($char[$i] eq '[') {
7619 0           my $left = $i;
7620             if ($char[$i+1] eq ']') {
7621 0           $i++;
7622 0 0         }
7623 0           while (1) {
7624             if (++$i > $#char) {
7625 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7626 0           }
7627             if ($char[$i] eq ']') {
7628             my $right = $i;
7629 0            
7630             # [...]
7631 0           splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
7632 0            
7633             $i = $left;
7634             last;
7635             }
7636             }
7637             }
7638              
7639 0           # open character class [^...]
7640 0 0         elsif ($char[$i] eq '[^') {
7641 0           my $left = $i;
7642             if ($char[$i+1] eq ']') {
7643 0           $i++;
7644 0 0         }
7645 0           while (1) {
7646             if (++$i > $#char) {
7647 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7648 0           }
7649             if ($char[$i] eq ']') {
7650             my $right = $i;
7651 0            
7652             # [^...]
7653 0           splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7654 0            
7655             $i = $left;
7656             last;
7657             }
7658             }
7659             }
7660              
7661 0           # rewrite character class or escape character
7662             elsif (my $char = character_class($char[$i],$modifier)) {
7663             $char[$i] = $char;
7664             }
7665              
7666 0           # split(m/^/) --> split(m/^/m)
7667             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7668             $modifier .= 'm';
7669             }
7670              
7671 0 0         # /i modifier
7672 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
7673             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
7674             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
7675 0           }
7676             else {
7677             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
7678             }
7679             }
7680              
7681 0 0         # quote character before ? + * {
7682             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7683             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7684 0           }
7685             else {
7686             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7687             }
7688             }
7689 0           }
7690 0            
7691             $modifier =~ tr/i//d;
7692             return join '', 'Elatin5::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7693             }
7694              
7695             #
7696             # instead of Carp::carp
7697 0     0 0   #
7698 0           sub carp {
7699             my($package,$filename,$line) = caller(1);
7700             print STDERR "@_ at $filename line $line.\n";
7701             }
7702              
7703             #
7704             # instead of Carp::croak
7705 0     0 0   #
7706 0           sub croak {
7707 0           my($package,$filename,$line) = caller(1);
7708             print STDERR "@_ at $filename line $line.\n";
7709             die "\n";
7710             }
7711              
7712             #
7713             # instead of Carp::cluck
7714 0     0 0   #
7715 0           sub cluck {
7716 0           my $i = 0;
7717 0           my @cluck = ();
7718 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7719             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7720 0           $i++;
7721 0           }
7722 0           print STDERR CORE::reverse @cluck;
7723             print STDERR "\n";
7724             print STDERR @_;
7725             }
7726              
7727             #
7728             # instead of Carp::confess
7729 0     0 0   #
7730 0           sub confess {
7731 0           my $i = 0;
7732 0           my @confess = ();
7733 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7734             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7735 0           $i++;
7736 0           }
7737 0           print STDERR CORE::reverse @confess;
7738 0           print STDERR "\n";
7739             print STDERR @_;
7740             die "\n";
7741             }
7742              
7743             1;
7744              
7745             __END__