File Coverage

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


line stmt bran cond sub pod time code
1             package Elatin5;
2 204     204   1238 use strict;
  204         407  
  204         6321  
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   2924 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   1006 use vars qw($VERSION);
  204         402  
  204         53888  
28             $VERSION = '1.15';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1643 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         343 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         37014 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   19852 CORE::eval q{
  204     204   1436  
  204     80   370  
  204         25405  
  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       107254 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     0 0 0 my($name) = @_;
78              
79 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
80 0         0 return $name;
81             }
82             elsif (Elatin5::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Elatin5::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 0         0 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 0   0 0 0 if (defined $_[1]) {
117 204     204   1450 no strict qw(refs);
  204         716  
  204         14799  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   1319 no strict qw(refs);
  204     0   505  
  204         40669  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x00-\xFF]};
153 204     204   1249 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         483  
  204         13692  
154 204     204   1268 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         368  
  204         372683  
155              
156             #
157             # Latin-5 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Latin-5 case conversion
163             #
164             my %lc = ();
165             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
166             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
167             my %uc = ();
168             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
169             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
170             my %fc = ();
171             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
172             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Elatin5 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
185             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
186             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
187             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
188             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
189             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
190             "\xC6" => "\xE6", # LATIN LETTER AE
191             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
192             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
193             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
194             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
195             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
196             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
197             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
198             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
199             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
200             "\xD0" => "\xF0", # LATIN LETTER G WITH BREVE
201             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
202             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
203             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
204             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
205             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
206             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
207             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
208             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
209             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
210             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
211             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
212             "\xDE" => "\xFE", # LATIN LETTER S WITH CEDILLA
213             );
214              
215             %uc = (%uc,
216             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
217             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
218             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
219             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
220             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
221             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
222             "\xE6" => "\xC6", # LATIN LETTER AE
223             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
224             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
225             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
226             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
227             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
228             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
229             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
230             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
231             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
232             "\xF0" => "\xD0", # LATIN LETTER G WITH BREVE
233             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
234             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
235             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
236             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
237             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
238             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
239             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
240             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
241             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
242             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
243             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
244             "\xFE" => "\xDE", # LATIN LETTER S WITH CEDILLA
245             );
246              
247             %fc = (%fc,
248             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
249             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
250             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
251             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
252             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
253             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
254             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
255             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
256             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
257             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
258             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
259             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
260             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
261             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
262             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
263             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
264             "\xD0" => "\xF0", # LATIN CAPITAL LETTER G WITH BREVE --> LATIN SMALL LETTER G WITH BREVE
265             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
266             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
267             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
268             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
269             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
270             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
271             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
272             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
273             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
274             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
275             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
276              
277             # CaseFolding-6.1.0.txt
278             # Date: 2011-07-25, 21:21:56 GMT [MD]
279             #
280             # T: special case for uppercase I and dotted uppercase I
281             # - For non-Turkic languages, this mapping is normally not used.
282             # - For Turkic languages (tr, az), this mapping can be used instead of the normal mapping for these characters.
283             # Note that the Turkic mappings do not maintain canonical equivalence without additional processing.
284             # See the discussions of case mapping in the Unicode Standard for more information.
285              
286             #-------------------------------------------------------------------------------
287             "\xDD" => "\x69", # LATIN CAPITAL LETTER I WITH DOT ABOVE
288             # --> LATIN SMALL LETTER I (without COMBINING DOT ABOVE)
289             #-------------------------------------------------------------------------------
290              
291             "\xDE" => "\xFE", # LATIN CAPITAL LETTER S WITH CEDILLA --> LATIN SMALL LETTER S WITH CEDILLA
292             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
293             );
294             }
295              
296             else {
297             croak "Don't know my package name '@{[__PACKAGE__]}'";
298             }
299              
300             #
301             # @ARGV wildcard globbing
302             #
303             sub import {
304              
305 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
306 0         0 my @argv = ();
307 0         0 for (@ARGV) {
308              
309             # has space
310 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
311 0 0       0 if (my @glob = Elatin5::glob(qq{"$_"})) {
312 0         0 push @argv, @glob;
313             }
314             else {
315 0         0 push @argv, $_;
316             }
317             }
318              
319             # has wildcard metachar
320             elsif (/\A (?:$q_char)*? [*?] /oxms) {
321 0 0       0 if (my @glob = Elatin5::glob($_)) {
322 0         0 push @argv, @glob;
323             }
324             else {
325 0         0 push @argv, $_;
326             }
327             }
328              
329             # no wildcard globbing
330             else {
331 0         0 push @argv, $_;
332             }
333             }
334 0         0 @ARGV = @argv;
335             }
336              
337 0         0 *Char::ord = \&Latin5::ord;
338 0         0 *Char::ord_ = \&Latin5::ord_;
339 0         0 *Char::reverse = \&Latin5::reverse;
340 0         0 *Char::getc = \&Latin5::getc;
341 0         0 *Char::length = \&Latin5::length;
342 0         0 *Char::substr = \&Latin5::substr;
343 0         0 *Char::index = \&Latin5::index;
344 0         0 *Char::rindex = \&Latin5::rindex;
345 0         0 *Char::eval = \&Latin5::eval;
346 0         0 *Char::escape = \&Latin5::escape;
347 0         0 *Char::escape_token = \&Latin5::escape_token;
348 0         0 *Char::escape_script = \&Latin5::escape_script;
349             }
350              
351             # P.230 Care with Prototypes
352             # in Chapter 6: Subroutines
353             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
354             #
355             # If you aren't careful, you can get yourself into trouble with prototypes.
356             # But if you are careful, you can do a lot of neat things with them. This is
357             # all very powerful, of course, and should only be used in moderation to make
358             # the world a better place.
359              
360             # P.332 Care with Prototypes
361             # in Chapter 7: Subroutines
362             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
363             #
364             # If you aren't careful, you can get yourself into trouble with prototypes.
365             # But if you are careful, you can do a lot of neat things with them. This is
366             # all very powerful, of course, and should only be used in moderation to make
367             # the world a better place.
368              
369             #
370             # Prototypes of subroutines
371             #
372       0     sub unimport {}
373             sub Elatin5::split(;$$$);
374             sub Elatin5::tr($$$$;$);
375             sub Elatin5::chop(@);
376             sub Elatin5::index($$;$);
377             sub Elatin5::rindex($$;$);
378             sub Elatin5::lcfirst(@);
379             sub Elatin5::lcfirst_();
380             sub Elatin5::lc(@);
381             sub Elatin5::lc_();
382             sub Elatin5::ucfirst(@);
383             sub Elatin5::ucfirst_();
384             sub Elatin5::uc(@);
385             sub Elatin5::uc_();
386             sub Elatin5::fc(@);
387             sub Elatin5::fc_();
388             sub Elatin5::ignorecase;
389             sub Elatin5::classic_character_class;
390             sub Elatin5::capture;
391             sub Elatin5::chr(;$);
392             sub Elatin5::chr_();
393             sub Elatin5::glob($);
394             sub Elatin5::glob_();
395              
396             sub Latin5::ord(;$);
397             sub Latin5::ord_();
398             sub Latin5::reverse(@);
399             sub Latin5::getc(;*@);
400             sub Latin5::length(;$);
401             sub Latin5::substr($$;$$);
402             sub Latin5::index($$;$);
403             sub Latin5::rindex($$;$);
404             sub Latin5::escape(;$);
405              
406             #
407             # Regexp work
408             #
409 204         16118 use vars qw(
410             $re_a
411             $re_t
412             $re_n
413             $re_r
414 204     204   1593 );
  204         397  
415              
416             #
417             # Character class
418             #
419 204         2099510 use vars qw(
420             $dot
421             $dot_s
422             $eD
423             $eS
424             $eW
425             $eH
426             $eV
427             $eR
428             $eN
429             $not_alnum
430             $not_alpha
431             $not_ascii
432             $not_blank
433             $not_cntrl
434             $not_digit
435             $not_graph
436             $not_lower
437             $not_lower_i
438             $not_print
439             $not_punct
440             $not_space
441             $not_upper
442             $not_upper_i
443             $not_word
444             $not_xdigit
445             $eb
446             $eB
447 204     204   1180 );
  204         434  
448              
449             ${Elatin5::dot} = qr{(?>[^\x0A])};
450             ${Elatin5::dot_s} = qr{(?>[\x00-\xFF])};
451             ${Elatin5::eD} = qr{(?>[^0-9])};
452              
453             # Vertical tabs are now whitespace
454             # \s in a regex now matches a vertical tab in all circumstances.
455             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
456             # ${Elatin5::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
457             # ${Elatin5::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
458             ${Elatin5::eS} = qr{(?>[^\s])};
459              
460             ${Elatin5::eW} = qr{(?>[^0-9A-Z_a-z])};
461             ${Elatin5::eH} = qr{(?>[^\x09\x20])};
462             ${Elatin5::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
463             ${Elatin5::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
464             ${Elatin5::eN} = qr{(?>[^\x0A])};
465             ${Elatin5::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
466             ${Elatin5::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
467             ${Elatin5::not_ascii} = qr{(?>[^\x00-\x7F])};
468             ${Elatin5::not_blank} = qr{(?>[^\x09\x20])};
469             ${Elatin5::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
470             ${Elatin5::not_digit} = qr{(?>[^\x30-\x39])};
471             ${Elatin5::not_graph} = qr{(?>[^\x21-\x7F])};
472             ${Elatin5::not_lower} = qr{(?>[^\x61-\x7A])};
473             ${Elatin5::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
474             # ${Elatin5::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
475             ${Elatin5::not_print} = qr{(?>[^\x20-\x7F])};
476             ${Elatin5::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
477             ${Elatin5::not_space} = qr{(?>[^\s\x0B])};
478             ${Elatin5::not_upper} = qr{(?>[^\x41-\x5A])};
479             ${Elatin5::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
480             # ${Elatin5::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
481             ${Elatin5::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
482             ${Elatin5::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
483             ${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))};
484             ${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]))};
485              
486             # avoid: Name "Elatin5::foo" used only once: possible typo at here.
487             ${Elatin5::dot} = ${Elatin5::dot};
488             ${Elatin5::dot_s} = ${Elatin5::dot_s};
489             ${Elatin5::eD} = ${Elatin5::eD};
490             ${Elatin5::eS} = ${Elatin5::eS};
491             ${Elatin5::eW} = ${Elatin5::eW};
492             ${Elatin5::eH} = ${Elatin5::eH};
493             ${Elatin5::eV} = ${Elatin5::eV};
494             ${Elatin5::eR} = ${Elatin5::eR};
495             ${Elatin5::eN} = ${Elatin5::eN};
496             ${Elatin5::not_alnum} = ${Elatin5::not_alnum};
497             ${Elatin5::not_alpha} = ${Elatin5::not_alpha};
498             ${Elatin5::not_ascii} = ${Elatin5::not_ascii};
499             ${Elatin5::not_blank} = ${Elatin5::not_blank};
500             ${Elatin5::not_cntrl} = ${Elatin5::not_cntrl};
501             ${Elatin5::not_digit} = ${Elatin5::not_digit};
502             ${Elatin5::not_graph} = ${Elatin5::not_graph};
503             ${Elatin5::not_lower} = ${Elatin5::not_lower};
504             ${Elatin5::not_lower_i} = ${Elatin5::not_lower_i};
505             ${Elatin5::not_print} = ${Elatin5::not_print};
506             ${Elatin5::not_punct} = ${Elatin5::not_punct};
507             ${Elatin5::not_space} = ${Elatin5::not_space};
508             ${Elatin5::not_upper} = ${Elatin5::not_upper};
509             ${Elatin5::not_upper_i} = ${Elatin5::not_upper_i};
510             ${Elatin5::not_word} = ${Elatin5::not_word};
511             ${Elatin5::not_xdigit} = ${Elatin5::not_xdigit};
512             ${Elatin5::eb} = ${Elatin5::eb};
513             ${Elatin5::eB} = ${Elatin5::eB};
514              
515             #
516             # Latin-5 split
517             #
518             sub Elatin5::split(;$$$) {
519              
520             # P.794 29.2.161. split
521             # in Chapter 29: Functions
522             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
523              
524             # P.951 split
525             # in Chapter 27: Functions
526             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
527              
528 0     0 0 0 my $pattern = $_[0];
529 0         0 my $string = $_[1];
530 0         0 my $limit = $_[2];
531              
532             # if $pattern is also omitted or is the literal space, " "
533 0 0       0 if (not defined $pattern) {
534 0         0 $pattern = ' ';
535             }
536              
537             # if $string is omitted, the function splits the $_ string
538 0 0       0 if (not defined $string) {
539 0 0       0 if (defined $_) {
540 0         0 $string = $_;
541             }
542             else {
543 0         0 $string = '';
544             }
545             }
546              
547 0         0 my @split = ();
548              
549             # when string is empty
550 0 0       0 if ($string eq '') {
    0          
551              
552             # resulting list value in list context
553 0 0       0 if (wantarray) {
554 0         0 return @split;
555             }
556              
557             # count of substrings in scalar context
558             else {
559 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
560 0         0 @_ = @split;
561 0         0 return scalar @_;
562             }
563             }
564              
565             # split's first argument is more consistently interpreted
566             #
567             # After some changes earlier in v5.17, split's behavior has been simplified:
568             # if the PATTERN argument evaluates to a string containing one space, it is
569             # treated the way that a literal string containing one space once was.
570             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
571              
572             # if $pattern is also omitted or is the literal space, " ", the function splits
573             # on whitespace, /\s+/, after skipping any leading whitespace
574             # (and so on)
575              
576             elsif ($pattern eq ' ') {
577 0 0       0 if (not defined $limit) {
578 0         0 return CORE::split(' ', $string);
579             }
580             else {
581 0         0 return CORE::split(' ', $string, $limit);
582             }
583             }
584              
585             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
586 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
587              
588             # a pattern capable of matching either the null string or something longer than the
589             # null string will split the value of $string into separate characters wherever it
590             # matches the null string between characters
591             # (and so on)
592              
593 0 0       0 if ('' =~ / \A $pattern \z /xms) {
594 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
595 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
596              
597             # P.1024 Appendix W.10 Multibyte Processing
598             # of ISBN 1-56592-224-7 CJKV Information Processing
599             # (and so on)
600              
601             # the //m modifier is assumed when you split on the pattern /^/
602             # (and so on)
603              
604             # V
605 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
606              
607             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
608             # is included in the resulting list, interspersed with the fields that are ordinarily returned
609             # (and so on)
610              
611 0         0 local $@;
612 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
613 0         0 push @split, CORE::eval('$' . $digit);
614             }
615             }
616             }
617              
618             else {
619 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
620              
621             # V
622 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
623 0         0 local $@;
624 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
625 0         0 push @split, CORE::eval('$' . $digit);
626             }
627             }
628             }
629             }
630              
631             elsif ($limit > 0) {
632 0 0       0 if ('' =~ / \A $pattern \z /xms) {
633 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
634 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
635              
636             # V
637 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
638 0         0 local $@;
639 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
640 0         0 push @split, CORE::eval('$' . $digit);
641             }
642             }
643             }
644             }
645             else {
646 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
647 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
648              
649             # V
650 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
651 0         0 local $@;
652 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
653 0         0 push @split, CORE::eval('$' . $digit);
654             }
655             }
656             }
657             }
658             }
659              
660 0 0       0 if (CORE::length($string) > 0) {
661 0         0 push @split, $string;
662             }
663              
664             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
665 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
666 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
667 0         0 pop @split;
668             }
669             }
670              
671             # resulting list value in list context
672 0 0       0 if (wantarray) {
673 0         0 return @split;
674             }
675              
676             # count of substrings in scalar context
677             else {
678 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
679 0         0 @_ = @split;
680 0         0 return scalar @_;
681             }
682             }
683              
684             #
685             # get last subexpression offsets
686             #
687             sub _last_subexpression_offsets {
688 0     0   0 my $pattern = $_[0];
689              
690             # remove comment
691 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
692              
693 0         0 my $modifier = '';
694 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
695 0         0 $modifier = $1;
696 0         0 $modifier =~ s/-[A-Za-z]*//;
697             }
698              
699             # with /x modifier
700 0         0 my @char = ();
701 0 0       0 if ($modifier =~ /x/oxms) {
702 0         0 @char = $pattern =~ /\G((?>
703             [^\\\#\[\(] |
704             \\ $q_char |
705             \# (?>[^\n]*) $ |
706             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
707             \(\? |
708             $q_char
709             ))/oxmsg;
710             }
711              
712             # without /x modifier
713             else {
714 0         0 @char = $pattern =~ /\G((?>
715             [^\\\[\(] |
716             \\ $q_char |
717             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
718             \(\? |
719             $q_char
720             ))/oxmsg;
721             }
722              
723 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
724             }
725              
726             #
727             # Latin-5 transliteration (tr///)
728             #
729             sub Elatin5::tr($$$$;$) {
730              
731 0     0 0 0 my $bind_operator = $_[1];
732 0         0 my $searchlist = $_[2];
733 0         0 my $replacementlist = $_[3];
734 0   0     0 my $modifier = $_[4] || '';
735              
736 0 0       0 if ($modifier =~ /r/oxms) {
737 0 0       0 if ($bind_operator =~ / !~ /oxms) {
738 0         0 croak "Using !~ with tr///r doesn't make sense";
739             }
740             }
741              
742 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
743 0         0 my @searchlist = _charlist_tr($searchlist);
744 0         0 my @replacementlist = _charlist_tr($replacementlist);
745              
746 0         0 my %tr = ();
747 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
748 0 0       0 if (not exists $tr{$searchlist[$i]}) {
749 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
750 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
751             }
752             elsif ($modifier =~ /d/oxms) {
753 0         0 $tr{$searchlist[$i]} = '';
754             }
755             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
756 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
757             }
758             else {
759 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
760             }
761             }
762             }
763              
764 0         0 my $tr = 0;
765 0         0 my $replaced = '';
766 0 0       0 if ($modifier =~ /c/oxms) {
767 0         0 while (defined(my $char = shift @char)) {
768 0 0       0 if (not exists $tr{$char}) {
769 0 0       0 if (defined $replacementlist[0]) {
770 0         0 $replaced .= $replacementlist[0];
771             }
772 0         0 $tr++;
773 0 0       0 if ($modifier =~ /s/oxms) {
774 0   0     0 while (@char and (not exists $tr{$char[0]})) {
775 0         0 shift @char;
776 0         0 $tr++;
777             }
778             }
779             }
780             else {
781 0         0 $replaced .= $char;
782             }
783             }
784             }
785             else {
786 0         0 while (defined(my $char = shift @char)) {
787 0 0       0 if (exists $tr{$char}) {
788 0         0 $replaced .= $tr{$char};
789 0         0 $tr++;
790 0 0       0 if ($modifier =~ /s/oxms) {
791 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
792 0         0 shift @char;
793 0         0 $tr++;
794             }
795             }
796             }
797             else {
798 0         0 $replaced .= $char;
799             }
800             }
801             }
802              
803 0 0       0 if ($modifier =~ /r/oxms) {
804 0         0 return $replaced;
805             }
806             else {
807 0         0 $_[0] = $replaced;
808 0 0       0 if ($bind_operator =~ / !~ /oxms) {
809 0         0 return not $tr;
810             }
811             else {
812 0         0 return $tr;
813             }
814             }
815             }
816              
817             #
818             # Latin-5 chop
819             #
820             sub Elatin5::chop(@) {
821              
822 0     0 0 0 my $chop;
823 0 0       0 if (@_ == 0) {
824 0         0 my @char = /\G (?>$q_char) /oxmsg;
825 0         0 $chop = pop @char;
826 0         0 $_ = join '', @char;
827             }
828             else {
829 0         0 for (@_) {
830 0         0 my @char = /\G (?>$q_char) /oxmsg;
831 0         0 $chop = pop @char;
832 0         0 $_ = join '', @char;
833             }
834             }
835 0         0 return $chop;
836             }
837              
838             #
839             # Latin-5 index by octet
840             #
841             sub Elatin5::index($$;$) {
842              
843 0     0 1 0 my($str,$substr,$position) = @_;
844 0   0     0 $position ||= 0;
845 0         0 my $pos = 0;
846              
847 0         0 while ($pos < CORE::length($str)) {
848 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
849 0 0       0 if ($pos >= $position) {
850 0         0 return $pos;
851             }
852             }
853 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
854 0         0 $pos += CORE::length($1);
855             }
856             else {
857 0         0 $pos += 1;
858             }
859             }
860 0         0 return -1;
861             }
862              
863             #
864             # Latin-5 reverse index
865             #
866             sub Elatin5::rindex($$;$) {
867              
868 0     0 0 0 my($str,$substr,$position) = @_;
869 0   0     0 $position ||= CORE::length($str) - 1;
870 0         0 my $pos = 0;
871 0         0 my $rindex = -1;
872              
873 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
874 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
875 0         0 $rindex = $pos;
876             }
877 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
878 0         0 $pos += CORE::length($1);
879             }
880             else {
881 0         0 $pos += 1;
882             }
883             }
884 0         0 return $rindex;
885             }
886              
887             #
888             # Latin-5 lower case first with parameter
889             #
890             sub Elatin5::lcfirst(@) {
891 0 0   0 0 0 if (@_) {
892 0         0 my $s = shift @_;
893 0 0 0     0 if (@_ and wantarray) {
894 0         0 return Elatin5::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
895             }
896             else {
897 0         0 return Elatin5::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
898             }
899             }
900             else {
901 0         0 return Elatin5::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
902             }
903             }
904              
905             #
906             # Latin-5 lower case first without parameter
907             #
908             sub Elatin5::lcfirst_() {
909 0     0 0 0 return Elatin5::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
910             }
911              
912             #
913             # Latin-5 lower case with parameter
914             #
915             sub Elatin5::lc(@) {
916 0 0   0 0 0 if (@_) {
917 0         0 my $s = shift @_;
918 0 0 0     0 if (@_ and wantarray) {
919 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
920             }
921             else {
922 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
923             }
924             }
925             else {
926 0         0 return Elatin5::lc_();
927             }
928             }
929              
930             #
931             # Latin-5 lower case without parameter
932             #
933             sub Elatin5::lc_() {
934 0     0 0 0 my $s = $_;
935 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
936             }
937              
938             #
939             # Latin-5 upper case first with parameter
940             #
941             sub Elatin5::ucfirst(@) {
942 0 0   0 0 0 if (@_) {
943 0         0 my $s = shift @_;
944 0 0 0     0 if (@_ and wantarray) {
945 0         0 return Elatin5::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
946             }
947             else {
948 0         0 return Elatin5::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
949             }
950             }
951             else {
952 0         0 return Elatin5::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
953             }
954             }
955              
956             #
957             # Latin-5 upper case first without parameter
958             #
959             sub Elatin5::ucfirst_() {
960 0     0 0 0 return Elatin5::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
961             }
962              
963             #
964             # Latin-5 upper case with parameter
965             #
966             sub Elatin5::uc(@) {
967 0 50   174 0 0 if (@_) {
968 174         272 my $s = shift @_;
969 174 50 33     204 if (@_ and wantarray) {
970 174 0       297 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
971             }
972             else {
973 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         526  
974             }
975             }
976             else {
977 174         734 return Elatin5::uc_();
978             }
979             }
980              
981             #
982             # Latin-5 upper case without parameter
983             #
984             sub Elatin5::uc_() {
985 0     0 0 0 my $s = $_;
986 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
987             }
988              
989             #
990             # Latin-5 fold case with parameter
991             #
992             sub Elatin5::fc(@) {
993 0 50   197 0 0 if (@_) {
994 197         273 my $s = shift @_;
995 197 50 33     232 if (@_ and wantarray) {
996 197 0       338 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
997             }
998             else {
999 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         473  
1000             }
1001             }
1002             else {
1003 197         1075 return Elatin5::fc_();
1004             }
1005             }
1006              
1007             #
1008             # Latin-5 fold case without parameter
1009             #
1010             sub Elatin5::fc_() {
1011 0     0 0 0 my $s = $_;
1012 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1013             }
1014              
1015             #
1016             # Latin-5 regexp capture
1017             #
1018             {
1019             sub Elatin5::capture {
1020 0     0 1 0 return $_[0];
1021             }
1022             }
1023              
1024             #
1025             # Latin-5 regexp ignore case modifier
1026             #
1027             sub Elatin5::ignorecase {
1028              
1029 0     0 0 0 my @string = @_;
1030 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1031              
1032             # ignore case of $scalar or @array
1033 0         0 for my $string (@string) {
1034              
1035             # split regexp
1036 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1037              
1038             # unescape character
1039 0         0 for (my $i=0; $i <= $#char; $i++) {
1040 0 0       0 next if not defined $char[$i];
1041              
1042             # open character class [...]
1043 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1044 0         0 my $left = $i;
1045              
1046             # [] make die "unmatched [] in regexp ...\n"
1047              
1048 0 0       0 if ($char[$i+1] eq ']') {
1049 0         0 $i++;
1050             }
1051              
1052 0         0 while (1) {
1053 0 0       0 if (++$i > $#char) {
1054 0         0 croak "Unmatched [] in regexp";
1055             }
1056 0 0       0 if ($char[$i] eq ']') {
1057 0         0 my $right = $i;
1058 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1059              
1060             # escape character
1061 0         0 for my $char (@charlist) {
1062 0 0       0 if (0) {
1063             }
1064              
1065 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1066 0         0 $char = '\\' . $char;
1067             }
1068             }
1069              
1070             # [...]
1071 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1072              
1073 0         0 $i = $left;
1074 0         0 last;
1075             }
1076             }
1077             }
1078              
1079             # open character class [^...]
1080             elsif ($char[$i] eq '[^') {
1081 0         0 my $left = $i;
1082              
1083             # [^] make die "unmatched [] in regexp ...\n"
1084              
1085 0 0       0 if ($char[$i+1] eq ']') {
1086 0         0 $i++;
1087             }
1088              
1089 0         0 while (1) {
1090 0 0       0 if (++$i > $#char) {
1091 0         0 croak "Unmatched [] in regexp";
1092             }
1093 0 0       0 if ($char[$i] eq ']') {
1094 0         0 my $right = $i;
1095 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1096              
1097             # escape character
1098 0         0 for my $char (@charlist) {
1099 0 0       0 if (0) {
1100             }
1101              
1102 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1103 0         0 $char = '\\' . $char;
1104             }
1105             }
1106              
1107             # [^...]
1108 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1109              
1110 0         0 $i = $left;
1111 0         0 last;
1112             }
1113             }
1114             }
1115              
1116             # rewrite classic character class or escape character
1117             elsif (my $char = classic_character_class($char[$i])) {
1118 0         0 $char[$i] = $char;
1119             }
1120              
1121             # with /i modifier
1122             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1123 0         0 my $uc = Elatin5::uc($char[$i]);
1124 0         0 my $fc = Elatin5::fc($char[$i]);
1125 0 0       0 if ($uc ne $fc) {
1126 0 0       0 if (CORE::length($fc) == 1) {
1127 0         0 $char[$i] = '[' . $uc . $fc . ']';
1128             }
1129             else {
1130 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1131             }
1132             }
1133             }
1134             }
1135              
1136             # characterize
1137 0         0 for (my $i=0; $i <= $#char; $i++) {
1138 0 0       0 next if not defined $char[$i];
1139              
1140 0 0       0 if (0) {
1141             }
1142              
1143             # quote character before ? + * {
1144 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1145 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1146 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1147             }
1148             }
1149             }
1150              
1151 0         0 $string = join '', @char;
1152             }
1153              
1154             # make regexp string
1155 0         0 return @string;
1156             }
1157              
1158             #
1159             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1160             #
1161             sub Elatin5::classic_character_class {
1162 0     1867 0 0 my($char) = @_;
1163              
1164             return {
1165             '\D' => '${Elatin5::eD}',
1166             '\S' => '${Elatin5::eS}',
1167             '\W' => '${Elatin5::eW}',
1168             '\d' => '[0-9]',
1169              
1170             # Before Perl 5.6, \s only matched the five whitespace characters
1171             # tab, newline, form-feed, carriage return, and the space character
1172             # itself, which, taken together, is the character class [\t\n\f\r ].
1173              
1174             # Vertical tabs are now whitespace
1175             # \s in a regex now matches a vertical tab in all circumstances.
1176             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1177             # \t \n \v \f \r space
1178             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1179             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1180             '\s' => '\s',
1181              
1182             '\w' => '[0-9A-Z_a-z]',
1183             '\C' => '[\x00-\xFF]',
1184             '\X' => 'X',
1185              
1186             # \h \v \H \V
1187              
1188             # P.114 Character Class Shortcuts
1189             # in Chapter 7: In the World of Regular Expressions
1190             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1191              
1192             # P.357 13.2.3 Whitespace
1193             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1194             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1195             #
1196             # 0x00009 CHARACTER TABULATION h s
1197             # 0x0000a LINE FEED (LF) vs
1198             # 0x0000b LINE TABULATION v
1199             # 0x0000c FORM FEED (FF) vs
1200             # 0x0000d CARRIAGE RETURN (CR) vs
1201             # 0x00020 SPACE h s
1202              
1203             # P.196 Table 5-9. Alphanumeric regex metasymbols
1204             # in Chapter 5. Pattern Matching
1205             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1206              
1207             # (and so on)
1208              
1209             '\H' => '${Elatin5::eH}',
1210             '\V' => '${Elatin5::eV}',
1211             '\h' => '[\x09\x20]',
1212             '\v' => '[\x0A\x0B\x0C\x0D]',
1213             '\R' => '${Elatin5::eR}',
1214              
1215             # \N
1216             #
1217             # http://perldoc.perl.org/perlre.html
1218             # Character Classes and other Special Escapes
1219             # Any character but \n (experimental). Not affected by /s modifier
1220              
1221             '\N' => '${Elatin5::eN}',
1222              
1223             # \b \B
1224              
1225             # P.180 Boundaries: The \b and \B Assertions
1226             # in Chapter 5: Pattern Matching
1227             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1228              
1229             # P.219 Boundaries: The \b and \B Assertions
1230             # in Chapter 5: Pattern Matching
1231             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1232              
1233             # \b really means (?:(?<=\w)(?!\w)|(?
1234             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1235             '\b' => '${Elatin5::eb}',
1236              
1237             # \B really means (?:(?<=\w)(?=\w)|(?
1238             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1239             '\B' => '${Elatin5::eB}',
1240              
1241 1867   100     2882 }->{$char} || '';
1242             }
1243              
1244             #
1245             # prepare Latin-5 characters per length
1246             #
1247              
1248             # 1 octet characters
1249             my @chars1 = ();
1250             sub chars1 {
1251 1867 0   0 0 69318 if (@chars1) {
1252 0         0 return @chars1;
1253             }
1254 0 0       0 if (exists $range_tr{1}) {
1255 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1256 0         0 while (my @range = splice(@ranges,0,1)) {
1257 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1258 0         0 push @chars1, pack 'C', $oct0;
1259             }
1260             }
1261             }
1262 0         0 return @chars1;
1263             }
1264              
1265             # 2 octets characters
1266             my @chars2 = ();
1267             sub chars2 {
1268 0 0   0 0 0 if (@chars2) {
1269 0         0 return @chars2;
1270             }
1271 0 0       0 if (exists $range_tr{2}) {
1272 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1273 0         0 while (my @range = splice(@ranges,0,2)) {
1274 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1275 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1276 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1277             }
1278             }
1279             }
1280             }
1281 0         0 return @chars2;
1282             }
1283              
1284             # 3 octets characters
1285             my @chars3 = ();
1286             sub chars3 {
1287 0 0   0 0 0 if (@chars3) {
1288 0         0 return @chars3;
1289             }
1290 0 0       0 if (exists $range_tr{3}) {
1291 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1292 0         0 while (my @range = splice(@ranges,0,3)) {
1293 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1294 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1295 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1296 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1297             }
1298             }
1299             }
1300             }
1301             }
1302 0         0 return @chars3;
1303             }
1304              
1305             # 4 octets characters
1306             my @chars4 = ();
1307             sub chars4 {
1308 0 0   0 0 0 if (@chars4) {
1309 0         0 return @chars4;
1310             }
1311 0 0       0 if (exists $range_tr{4}) {
1312 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1313 0         0 while (my @range = splice(@ranges,0,4)) {
1314 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1315 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1316 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1317 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1318 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1319             }
1320             }
1321             }
1322             }
1323             }
1324             }
1325 0         0 return @chars4;
1326             }
1327              
1328             #
1329             # Latin-5 open character list for tr
1330             #
1331             sub _charlist_tr {
1332              
1333 0     0   0 local $_ = shift @_;
1334              
1335             # unescape character
1336 0         0 my @char = ();
1337 0         0 while (not /\G \z/oxmsgc) {
1338 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1339 0         0 push @char, '\-';
1340             }
1341             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1342 0         0 push @char, CORE::chr(oct $1);
1343             }
1344             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1345 0         0 push @char, CORE::chr(hex $1);
1346             }
1347             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1348 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1349             }
1350             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1351             push @char, {
1352             '\0' => "\0",
1353             '\n' => "\n",
1354             '\r' => "\r",
1355             '\t' => "\t",
1356             '\f' => "\f",
1357             '\b' => "\x08", # \b means backspace in character class
1358             '\a' => "\a",
1359             '\e' => "\e",
1360 0         0 }->{$1};
1361             }
1362             elsif (/\G \\ ($q_char) /oxmsgc) {
1363 0         0 push @char, $1;
1364             }
1365             elsif (/\G ($q_char) /oxmsgc) {
1366 0         0 push @char, $1;
1367             }
1368             }
1369              
1370             # join separated multiple-octet
1371 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1372              
1373             # unescape '-'
1374 0         0 my @i = ();
1375 0         0 for my $i (0 .. $#char) {
1376 0 0       0 if ($char[$i] eq '\-') {
    0          
1377 0         0 $char[$i] = '-';
1378             }
1379             elsif ($char[$i] eq '-') {
1380 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1381 0         0 push @i, $i;
1382             }
1383             }
1384             }
1385              
1386             # open character list (reverse for splice)
1387 0         0 for my $i (CORE::reverse @i) {
1388 0         0 my @range = ();
1389              
1390             # range error
1391 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1392 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1393             }
1394              
1395             # range of multiple-octet code
1396 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1397 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1398 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1399             }
1400             elsif (CORE::length($char[$i+1]) == 2) {
1401 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1402 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1403             }
1404             elsif (CORE::length($char[$i+1]) == 3) {
1405 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1406 0         0 push @range, chars2();
1407 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1408             }
1409             elsif (CORE::length($char[$i+1]) == 4) {
1410 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1411 0         0 push @range, chars2();
1412 0         0 push @range, chars3();
1413 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1414             }
1415             else {
1416 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1417             }
1418             }
1419             elsif (CORE::length($char[$i-1]) == 2) {
1420 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1421 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1422             }
1423             elsif (CORE::length($char[$i+1]) == 3) {
1424 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1425 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1426             }
1427             elsif (CORE::length($char[$i+1]) == 4) {
1428 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1429 0         0 push @range, chars3();
1430 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1431             }
1432             else {
1433 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1434             }
1435             }
1436             elsif (CORE::length($char[$i-1]) == 3) {
1437 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1438 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1439             }
1440             elsif (CORE::length($char[$i+1]) == 4) {
1441 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1442 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1443             }
1444             else {
1445 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1446             }
1447             }
1448             elsif (CORE::length($char[$i-1]) == 4) {
1449 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1450 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1451             }
1452             else {
1453 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1454             }
1455             }
1456             else {
1457 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1458             }
1459              
1460 0         0 splice @char, $i-1, 3, @range;
1461             }
1462              
1463 0         0 return @char;
1464             }
1465              
1466             #
1467             # Latin-5 open character class
1468             #
1469             sub _cc {
1470 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1471 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1472             }
1473             elsif (scalar(@_) == 1) {
1474 0         0 return sprintf('\x%02X',$_[0]);
1475             }
1476             elsif (scalar(@_) == 2) {
1477 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1478 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1479             }
1480             elsif ($_[0] == $_[1]) {
1481 0         0 return sprintf('\x%02X',$_[0]);
1482             }
1483             elsif (($_[0]+1) == $_[1]) {
1484 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1485             }
1486             else {
1487 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1488             }
1489             }
1490             else {
1491 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1492             }
1493             }
1494              
1495             #
1496             # Latin-5 octet range
1497             #
1498             sub _octets {
1499 0     182   0 my $length = shift @_;
1500              
1501 182 50       311 if ($length == 1) {
1502 182         462 my($a1) = unpack 'C', $_[0];
1503 182         556 my($z1) = unpack 'C', $_[1];
1504              
1505 182 50       356 if ($a1 > $z1) {
1506 182         358 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1507             }
1508              
1509 0 50       0 if ($a1 == $z1) {
    50          
1510 182         477 return sprintf('\x%02X',$a1);
1511             }
1512             elsif (($a1+1) == $z1) {
1513 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1514             }
1515             else {
1516 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1517             }
1518             }
1519             else {
1520 182         1139 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1521             }
1522             }
1523              
1524             #
1525             # Latin-5 range regexp
1526             #
1527             sub _range_regexp {
1528 0     182   0 my($length,$first,$last) = @_;
1529              
1530 182         400 my @range_regexp = ();
1531 182 50       240 if (not exists $range_tr{$length}) {
1532 182         452 return @range_regexp;
1533             }
1534              
1535 0         0 my @ranges = @{ $range_tr{$length} };
  182         275  
1536 182         420 while (my @range = splice(@ranges,0,$length)) {
1537 182         573 my $min = '';
1538 182         275 my $max = '';
1539 182         242 for (my $i=0; $i < $length; $i++) {
1540 182         491 $min .= pack 'C', $range[$i][0];
1541 182         665 $max .= pack 'C', $range[$i][-1];
1542             }
1543              
1544             # min___max
1545             # FIRST_____________LAST
1546             # (nothing)
1547              
1548 182 50 33     491 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1549             }
1550              
1551             # **********
1552             # min_________max
1553             # FIRST_____________LAST
1554             # **********
1555              
1556             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1557 182         1861 push @range_regexp, _octets($length,$first,$max,$min,$max);
1558             }
1559              
1560             # **********************
1561             # min________________max
1562             # FIRST_____________LAST
1563             # **********************
1564              
1565             elsif (($min eq $first) and ($max eq $last)) {
1566 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1567             }
1568              
1569             # *********
1570             # min___max
1571             # FIRST_____________LAST
1572             # *********
1573              
1574             elsif (($first le $min) and ($max le $last)) {
1575 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1576             }
1577              
1578             # **********************
1579             # min__________________________max
1580             # FIRST_____________LAST
1581             # **********************
1582              
1583             elsif (($min le $first) and ($last le $max)) {
1584 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1585             }
1586              
1587             # *********
1588             # min________max
1589             # FIRST_____________LAST
1590             # *********
1591              
1592             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1593 182         512 push @range_regexp, _octets($length,$min,$last,$min,$max);
1594             }
1595              
1596             # min___max
1597             # FIRST_____________LAST
1598             # (nothing)
1599              
1600             elsif ($last lt $min) {
1601             }
1602              
1603             else {
1604 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1605             }
1606             }
1607              
1608 0         0 return @range_regexp;
1609             }
1610              
1611             #
1612             # Latin-5 open character list for qr and not qr
1613             #
1614             sub _charlist {
1615              
1616 182     358   609 my $modifier = pop @_;
1617 358         663 my @char = @_;
1618              
1619 358 100       744 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1620              
1621             # unescape character
1622 358         778 for (my $i=0; $i <= $#char; $i++) {
1623              
1624             # escape - to ...
1625 358 100 100     1561 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1626 1125 100 100     14258 if ((0 < $i) and ($i < $#char)) {
1627 206         729 $char[$i] = '...';
1628             }
1629             }
1630              
1631             # octal escape sequence
1632             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1633 182         379 $char[$i] = octchr($1);
1634             }
1635              
1636             # hexadecimal escape sequence
1637             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1638 0         0 $char[$i] = hexchr($1);
1639             }
1640              
1641             # \b{...} --> b\{...}
1642             # \B{...} --> B\{...}
1643             # \N{CHARNAME} --> N\{CHARNAME}
1644             # \p{PROPERTY} --> p\{PROPERTY}
1645             # \P{PROPERTY} --> P\{PROPERTY}
1646             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1647 0         0 $char[$i] = $1 . '\\' . $2;
1648             }
1649              
1650             # \p, \P, \X --> p, P, X
1651             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1652 0         0 $char[$i] = $1;
1653             }
1654              
1655             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1656 0         0 $char[$i] = CORE::chr oct $1;
1657             }
1658             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1659 0         0 $char[$i] = CORE::chr hex $1;
1660             }
1661             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1662 22         101 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1663             }
1664             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1665             $char[$i] = {
1666             '\0' => "\0",
1667             '\n' => "\n",
1668             '\r' => "\r",
1669             '\t' => "\t",
1670             '\f' => "\f",
1671             '\b' => "\x08", # \b means backspace in character class
1672             '\a' => "\a",
1673             '\e' => "\e",
1674             '\d' => '[0-9]',
1675              
1676             # Vertical tabs are now whitespace
1677             # \s in a regex now matches a vertical tab in all circumstances.
1678             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1679             # \t \n \v \f \r space
1680             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1681             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1682             '\s' => '\s',
1683              
1684             '\w' => '[0-9A-Z_a-z]',
1685             '\D' => '${Elatin5::eD}',
1686             '\S' => '${Elatin5::eS}',
1687             '\W' => '${Elatin5::eW}',
1688              
1689             '\H' => '${Elatin5::eH}',
1690             '\V' => '${Elatin5::eV}',
1691             '\h' => '[\x09\x20]',
1692             '\v' => '[\x0A\x0B\x0C\x0D]',
1693             '\R' => '${Elatin5::eR}',
1694              
1695 0         0 }->{$1};
1696             }
1697              
1698             # POSIX-style character classes
1699             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1700             $char[$i] = {
1701              
1702             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1703             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1704             '[:^lower:]' => '${Elatin5::not_lower_i}',
1705             '[:^upper:]' => '${Elatin5::not_upper_i}',
1706              
1707 25         429 }->{$1};
1708             }
1709             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1710             $char[$i] = {
1711              
1712             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1713             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1714             '[:ascii:]' => '[\x00-\x7F]',
1715             '[:blank:]' => '[\x09\x20]',
1716             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1717             '[:digit:]' => '[\x30-\x39]',
1718             '[:graph:]' => '[\x21-\x7F]',
1719             '[:lower:]' => '[\x61-\x7A]',
1720             '[:print:]' => '[\x20-\x7F]',
1721             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1722              
1723             # P.174 POSIX-Style Character Classes
1724             # in Chapter 5: Pattern Matching
1725             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1726              
1727             # P.311 11.2.4 Character Classes and other Special Escapes
1728             # in Chapter 11: perlre: Perl regular expressions
1729             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1730              
1731             # P.210 POSIX-Style Character Classes
1732             # in Chapter 5: Pattern Matching
1733             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1734              
1735             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1736              
1737             '[:upper:]' => '[\x41-\x5A]',
1738             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1739             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1740             '[:^alnum:]' => '${Elatin5::not_alnum}',
1741             '[:^alpha:]' => '${Elatin5::not_alpha}',
1742             '[:^ascii:]' => '${Elatin5::not_ascii}',
1743             '[:^blank:]' => '${Elatin5::not_blank}',
1744             '[:^cntrl:]' => '${Elatin5::not_cntrl}',
1745             '[:^digit:]' => '${Elatin5::not_digit}',
1746             '[:^graph:]' => '${Elatin5::not_graph}',
1747             '[:^lower:]' => '${Elatin5::not_lower}',
1748             '[:^print:]' => '${Elatin5::not_print}',
1749             '[:^punct:]' => '${Elatin5::not_punct}',
1750             '[:^space:]' => '${Elatin5::not_space}',
1751             '[:^upper:]' => '${Elatin5::not_upper}',
1752             '[:^word:]' => '${Elatin5::not_word}',
1753             '[:^xdigit:]' => '${Elatin5::not_xdigit}',
1754              
1755 8         66 }->{$1};
1756             }
1757             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1758 70         1210 $char[$i] = $1;
1759             }
1760             }
1761              
1762             # open character list
1763 7         31 my @singleoctet = ();
1764 358         682 my @multipleoctet = ();
1765 358         495 for (my $i=0; $i <= $#char; ) {
1766              
1767             # escaped -
1768 358 100 100     827 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1769 943         3851 $i += 1;
1770 182         295 next;
1771             }
1772              
1773             # make range regexp
1774             elsif ($char[$i] eq '...') {
1775              
1776             # range error
1777 182 50       334 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1778 182         764 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1779             }
1780             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1781 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1782 182         471 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1783             }
1784             }
1785              
1786             # make range regexp per length
1787 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1788 182         531 my @regexp = ();
1789              
1790             # is first and last
1791 182 50 33     245 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1792 182         665 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1793             }
1794              
1795             # is first
1796             elsif ($length == CORE::length($char[$i-1])) {
1797 182         520 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1798             }
1799              
1800             # is inside in first and last
1801             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1802 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1803             }
1804              
1805             # is last
1806             elsif ($length == CORE::length($char[$i+1])) {
1807 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1808             }
1809              
1810             else {
1811 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1812             }
1813              
1814 0 50       0 if ($length == 1) {
1815 182         355 push @singleoctet, @regexp;
1816             }
1817             else {
1818 182         438 push @multipleoctet, @regexp;
1819             }
1820             }
1821              
1822 0         0 $i += 2;
1823             }
1824              
1825             # with /i modifier
1826             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1827 182 100       417 if ($modifier =~ /i/oxms) {
1828 493         787 my $uc = Elatin5::uc($char[$i]);
1829 24         48 my $fc = Elatin5::fc($char[$i]);
1830 24 100       46 if ($uc ne $fc) {
1831 24 50       40 if (CORE::length($fc) == 1) {
1832 12         24 push @singleoctet, $uc, $fc;
1833             }
1834             else {
1835 12         19 push @singleoctet, $uc;
1836 0         0 push @multipleoctet, $fc;
1837             }
1838             }
1839             else {
1840 0         0 push @singleoctet, $char[$i];
1841             }
1842             }
1843             else {
1844 12         27 push @singleoctet, $char[$i];
1845             }
1846 469         740 $i += 1;
1847             }
1848              
1849             # single character of single octet code
1850             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1851 493         798 push @singleoctet, "\t", "\x20";
1852 0         0 $i += 1;
1853             }
1854             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1855 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1856 0         0 $i += 1;
1857             }
1858             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1859 0         0 push @singleoctet, $char[$i];
1860 2         5 $i += 1;
1861             }
1862              
1863             # single character of multiple-octet code
1864             else {
1865 2         5 push @multipleoctet, $char[$i];
1866 84         255 $i += 1;
1867             }
1868             }
1869              
1870             # quote metachar
1871 84         155 for (@singleoctet) {
1872 358 50       700 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1873 689         2860 $_ = '-';
1874             }
1875             elsif (/\A \n \z/oxms) {
1876 0         0 $_ = '\n';
1877             }
1878             elsif (/\A \r \z/oxms) {
1879 8         22 $_ = '\r';
1880             }
1881             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1882 8         29 $_ = sprintf('\x%02X', CORE::ord $1);
1883             }
1884             elsif (/\A [\x00-\xFF] \z/oxms) {
1885 60         237 $_ = quotemeta $_;
1886             }
1887             }
1888              
1889             # return character list
1890 429         758 return \@singleoctet, \@multipleoctet;
1891             }
1892              
1893             #
1894             # Latin-5 octal escape sequence
1895             #
1896             sub octchr {
1897 358     5 0 1223 my($octdigit) = @_;
1898              
1899 5         15 my @binary = ();
1900 5         7 for my $octal (split(//,$octdigit)) {
1901             push @binary, {
1902             '0' => '000',
1903             '1' => '001',
1904             '2' => '010',
1905             '3' => '011',
1906             '4' => '100',
1907             '5' => '101',
1908             '6' => '110',
1909             '7' => '111',
1910 5         36 }->{$octal};
1911             }
1912 50         181 my $binary = join '', @binary;
1913              
1914             my $octchr = {
1915             # 1234567
1916             1 => pack('B*', "0000000$binary"),
1917             2 => pack('B*', "000000$binary"),
1918             3 => pack('B*', "00000$binary"),
1919             4 => pack('B*', "0000$binary"),
1920             5 => pack('B*', "000$binary"),
1921             6 => pack('B*', "00$binary"),
1922             7 => pack('B*', "0$binary"),
1923             0 => pack('B*', "$binary"),
1924              
1925 5         14 }->{CORE::length($binary) % 8};
1926              
1927 5         56 return $octchr;
1928             }
1929              
1930             #
1931             # Latin-5 hexadecimal escape sequence
1932             #
1933             sub hexchr {
1934 5     5 0 20 my($hexdigit) = @_;
1935              
1936             my $hexchr = {
1937             1 => pack('H*', "0$hexdigit"),
1938             0 => pack('H*', "$hexdigit"),
1939              
1940 5         13 }->{CORE::length($_[0]) % 2};
1941              
1942 5         47 return $hexchr;
1943             }
1944              
1945             #
1946             # Latin-5 open character list for qr
1947             #
1948             sub charlist_qr {
1949              
1950 5     314 0 21 my $modifier = pop @_;
1951 314         586 my @char = @_;
1952              
1953 314         752 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1954 314         937 my @singleoctet = @$singleoctet;
1955 314         750 my @multipleoctet = @$multipleoctet;
1956              
1957             # return character list
1958 314 100       485 if (scalar(@singleoctet) >= 1) {
1959              
1960             # with /i modifier
1961 314 100       701 if ($modifier =~ m/i/oxms) {
1962 236         601 my %singleoctet_ignorecase = ();
1963 22         37 for (@singleoctet) {
1964 22   100     34 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1965 46         205 for my $ord (hex($1) .. hex($2)) {
1966 46         128 my $char = CORE::chr($ord);
1967 66         108 my $uc = Elatin5::uc($char);
1968 66         91 my $fc = Elatin5::fc($char);
1969 66 100       111 if ($uc eq $fc) {
1970 66         109 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1971             }
1972             else {
1973 12 50       77 if (CORE::length($fc) == 1) {
1974 54         80 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1975 54         135 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1976             }
1977             else {
1978 54         189 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1979 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1980             }
1981             }
1982             }
1983             }
1984 0 50       0 if ($_ ne '') {
1985 46         87 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1986             }
1987             }
1988 0         0 my $i = 0;
1989 22         26 my @singleoctet_ignorecase = ();
1990 22         32 for my $ord (0 .. 255) {
1991 22 100       33 if (exists $singleoctet_ignorecase{$ord}) {
1992 5632         6519 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         93  
1993             }
1994             else {
1995 96         215 $i++;
1996             }
1997             }
1998 5536         19608 @singleoctet = ();
1999 22         38 for my $range (@singleoctet_ignorecase) {
2000 22 100       58 if (ref $range) {
2001 3648 100       5586 if (scalar(@{$range}) == 1) {
  56 50       58  
2002 56         86 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         41  
2003             }
2004 36         131 elsif (scalar(@{$range}) == 2) {
2005 20         31 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2006             }
2007             else {
2008 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         23  
  20         23  
2009             }
2010             }
2011             }
2012             }
2013              
2014 20         82 my $not_anchor = '';
2015              
2016 236         395 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2017             }
2018 236 100       686 if (scalar(@multipleoctet) >= 2) {
2019 314         682 return '(?:' . join('|', @multipleoctet) . ')';
2020             }
2021             else {
2022 6         30 return $multipleoctet[0];
2023             }
2024             }
2025              
2026             #
2027             # Latin-5 open character list for not qr
2028             #
2029             sub charlist_not_qr {
2030              
2031 308     44 0 1292 my $modifier = pop @_;
2032 44         89 my @char = @_;
2033              
2034 44         99 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2035 44         113 my @singleoctet = @$singleoctet;
2036 44         98 my @multipleoctet = @$multipleoctet;
2037              
2038             # with /i modifier
2039 44 100       63 if ($modifier =~ m/i/oxms) {
2040 44         111 my %singleoctet_ignorecase = ();
2041 10         14 for (@singleoctet) {
2042 10   66     12 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2043 10         52 for my $ord (hex($1) .. hex($2)) {
2044 10         34 my $char = CORE::chr($ord);
2045 30         45 my $uc = Elatin5::uc($char);
2046 30         43 my $fc = Elatin5::fc($char);
2047 30 50       47 if ($uc eq $fc) {
2048 30         45 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2049             }
2050             else {
2051 0 50       0 if (CORE::length($fc) == 1) {
2052 30         39 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2053 30         70 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2054             }
2055             else {
2056 30         101 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2057 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2058             }
2059             }
2060             }
2061             }
2062 0 50       0 if ($_ ne '') {
2063 10         22 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2064             }
2065             }
2066 0         0 my $i = 0;
2067 10         13 my @singleoctet_ignorecase = ();
2068 10         12 for my $ord (0 .. 255) {
2069 10 100       16 if (exists $singleoctet_ignorecase{$ord}) {
2070 2560         3065 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         53  
2071             }
2072             else {
2073 60         202 $i++;
2074             }
2075             }
2076 2500         2682 @singleoctet = ();
2077 10         437 for my $range (@singleoctet_ignorecase) {
2078 10 100       30 if (ref $range) {
2079 960 50       1861 if (scalar(@{$range}) == 1) {
  20 50       20  
2080 20         30 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2081             }
2082 0         0 elsif (scalar(@{$range}) == 2) {
2083 20         28 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2084             }
2085             else {
2086 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         23  
  20         23  
2087             }
2088             }
2089             }
2090             }
2091              
2092             # return character list
2093 20 50       94 if (scalar(@multipleoctet) >= 1) {
2094 44 0       101 if (scalar(@singleoctet) >= 1) {
2095              
2096             # any character other than multiple-octet and single octet character class
2097 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2098             }
2099             else {
2100              
2101             # any character other than multiple-octet character class
2102 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2103             }
2104             }
2105             else {
2106 0 50       0 if (scalar(@singleoctet) >= 1) {
2107              
2108             # any character other than single octet character class
2109 44         115 return '(?:[^' . join('', @singleoctet) . '])';
2110             }
2111             else {
2112              
2113             # any character
2114 44         259 return "(?:$your_char)";
2115             }
2116             }
2117             }
2118              
2119             #
2120             # open file in read mode
2121             #
2122             sub _open_r {
2123 0     408   0 my(undef,$file) = @_;
2124 204     204   2175 use Fcntl qw(O_RDONLY);
  204         719  
  204         36890  
2125 408         1304 return CORE::sysopen($_[0], $file, &O_RDONLY);
2126             }
2127              
2128             #
2129             # open file in append mode
2130             #
2131             sub _open_a {
2132 408     204   17581 my(undef,$file) = @_;
2133 204     204   1495 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         407  
  204         677407  
2134 204         705 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2135             }
2136              
2137             #
2138             # safe system
2139             #
2140             sub _systemx {
2141              
2142             # P.707 29.2.33. exec
2143             # in Chapter 29: Functions
2144             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2145             #
2146             # Be aware that in older releases of Perl, exec (and system) did not flush
2147             # your output buffer, so you needed to enable command buffering by setting $|
2148             # on one or more filehandles to avoid lost output in the case of exec, or
2149             # misordererd output in the case of system. This situation was largely remedied
2150             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2151              
2152             # P.855 exec
2153             # in Chapter 27: Functions
2154             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2155             #
2156             # In very old release of Perl (before v5.6), exec (and system) did not flush
2157             # your output buffer, so you needed to enable command buffering by setting $|
2158             # on one or more filehandles to avoid lost output with exec or misordered
2159             # output with system.
2160              
2161 204     204   23239 $| = 1;
2162              
2163             # P.565 23.1.2. Cleaning Up Your Environment
2164             # in Chapter 23: Security
2165             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2166              
2167             # P.656 Cleaning Up Your Environment
2168             # in Chapter 20: Security
2169             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2170              
2171             # local $ENV{'PATH'} = '.';
2172 204         649 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2173              
2174             # P.707 29.2.33. exec
2175             # in Chapter 29: Functions
2176             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2177             #
2178             # As we mentioned earlier, exec treats a discrete list of arguments as an
2179             # indication that it should bypass shell processing. However, there is one
2180             # place where you might still get tripped up. The exec call (and system, too)
2181             # will not distinguish between a single scalar argument and an array containing
2182             # only one element.
2183             #
2184             # @args = ("echo surprise"); # just one element in list
2185             # exec @args # still subject to shell escapes
2186             # or die "exec: $!"; # because @args == 1
2187             #
2188             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2189             # first argument as the pathname, which forces the rest of the arguments to be
2190             # interpreted as a list, even if there is only one of them:
2191             #
2192             # exec { $args[0] } @args # safe even with one-argument list
2193             # or die "can't exec @args: $!";
2194              
2195             # P.855 exec
2196             # in Chapter 27: Functions
2197             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2198             #
2199             # As we mentioned earlier, exec treats a discrete list of arguments as a
2200             # directive to bypass shell processing. However, there is one place where
2201             # you might still get tripped up. The exec call (and system, too) cannot
2202             # distinguish between a single scalar argument and an array containing
2203             # only one element.
2204             #
2205             # @args = ("echo surprise"); # just one element in list
2206             # exec @args # still subject to shell escapes
2207             # || die "exec: $!"; # because @args == 1
2208             #
2209             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2210             # argument as the pathname, which forces the rest of the arguments to be
2211             # interpreted as a list, even if there is only one of them:
2212             #
2213             # exec { $args[0] } @args # safe even with one-argument list
2214             # || die "can't exec @args: $!";
2215              
2216 204         1727 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         408  
2217             }
2218              
2219             #
2220             # Latin-5 order to character (with parameter)
2221             #
2222             sub Elatin5::chr(;$) {
2223              
2224 204 0   0 0 19441132 my $c = @_ ? $_[0] : $_;
2225              
2226 0 0       0 if ($c == 0x00) {
2227 0         0 return "\x00";
2228             }
2229             else {
2230 0         0 my @chr = ();
2231 0         0 while ($c > 0) {
2232 0         0 unshift @chr, ($c % 0x100);
2233 0         0 $c = int($c / 0x100);
2234             }
2235 0         0 return pack 'C*', @chr;
2236             }
2237             }
2238              
2239             #
2240             # Latin-5 order to character (without parameter)
2241             #
2242             sub Elatin5::chr_() {
2243              
2244 0     0 0 0 my $c = $_;
2245              
2246 0 0       0 if ($c == 0x00) {
2247 0         0 return "\x00";
2248             }
2249             else {
2250 0         0 my @chr = ();
2251 0         0 while ($c > 0) {
2252 0         0 unshift @chr, ($c % 0x100);
2253 0         0 $c = int($c / 0x100);
2254             }
2255 0         0 return pack 'C*', @chr;
2256             }
2257             }
2258              
2259             #
2260             # Latin-5 path globbing (with parameter)
2261             #
2262             sub Elatin5::glob($) {
2263              
2264 0 0   0 0 0 if (wantarray) {
2265 0         0 my @glob = _DOS_like_glob(@_);
2266 0         0 for my $glob (@glob) {
2267 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2268             }
2269 0         0 return @glob;
2270             }
2271             else {
2272 0         0 my $glob = _DOS_like_glob(@_);
2273 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2274 0         0 return $glob;
2275             }
2276             }
2277              
2278             #
2279             # Latin-5 path globbing (without parameter)
2280             #
2281             sub Elatin5::glob_() {
2282              
2283 0 0   0 0 0 if (wantarray) {
2284 0         0 my @glob = _DOS_like_glob();
2285 0         0 for my $glob (@glob) {
2286 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2287             }
2288 0         0 return @glob;
2289             }
2290             else {
2291 0         0 my $glob = _DOS_like_glob();
2292 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2293 0         0 return $glob;
2294             }
2295             }
2296              
2297             #
2298             # Latin-5 path globbing via File::DosGlob 1.10
2299             #
2300             # Often I confuse "_dosglob" and "_doglob".
2301             # So, I renamed "_dosglob" to "_DOS_like_glob".
2302             #
2303             my %iter;
2304             my %entries;
2305             sub _DOS_like_glob {
2306              
2307             # context (keyed by second cxix argument provided by core)
2308 0     0   0 my($expr,$cxix) = @_;
2309              
2310             # glob without args defaults to $_
2311 0 0       0 $expr = $_ if not defined $expr;
2312              
2313             # represents the current user's home directory
2314             #
2315             # 7.3. Expanding Tildes in Filenames
2316             # in Chapter 7. File Access
2317             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2318             #
2319             # and File::HomeDir, File::HomeDir::Windows module
2320              
2321             # DOS-like system
2322 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2323 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2324             { my_home_MSWin32() }oxmse;
2325             }
2326              
2327             # UNIX-like system
2328 0 0 0     0 else {
  0         0  
2329             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2330             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2331             }
2332 0 0       0  
2333 0 0       0 # assume global context if not provided one
2334             $cxix = '_G_' if not defined $cxix;
2335             $iter{$cxix} = 0 if not exists $iter{$cxix};
2336 0 0       0  
2337 0         0 # if we're just beginning, do it all first
2338             if ($iter{$cxix} == 0) {
2339             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2340             }
2341 0 0       0  
2342 0         0 # chuck it all out, quick or slow
2343 0         0 if (wantarray) {
  0         0  
2344             delete $iter{$cxix};
2345             return @{delete $entries{$cxix}};
2346 0 0       0 }
  0         0  
2347 0         0 else {
  0         0  
2348             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2349             return shift @{$entries{$cxix}};
2350             }
2351 0         0 else {
2352 0         0 # return undef for EOL
2353 0         0 delete $iter{$cxix};
2354             delete $entries{$cxix};
2355             return undef;
2356             }
2357             }
2358             }
2359              
2360             #
2361             # Latin-5 path globbing subroutine
2362             #
2363 0     0   0 sub _do_glob {
2364 0         0  
2365 0         0 my($cond,@expr) = @_;
2366             my @glob = ();
2367             my $fix_drive_relative_paths = 0;
2368 0         0  
2369 0 0       0 OUTER:
2370 0 0       0 for my $expr (@expr) {
2371             next OUTER if not defined $expr;
2372 0         0 next OUTER if $expr eq '';
2373 0         0  
2374 0         0 my @matched = ();
2375 0         0 my @globdir = ();
2376 0         0 my $head = '.';
2377             my $pathsep = '/';
2378             my $tail;
2379 0 0       0  
2380 0         0 # if argument is within quotes strip em and do no globbing
2381 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2382 0 0       0 $expr = $1;
2383 0         0 if ($cond eq 'd') {
2384             if (-d $expr) {
2385             push @glob, $expr;
2386             }
2387 0 0       0 }
2388 0         0 else {
2389             if (-e $expr) {
2390             push @glob, $expr;
2391 0         0 }
2392             }
2393             next OUTER;
2394             }
2395              
2396 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2397 0 0       0 # to h:./*.pm to expand correctly
2398 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2399             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2400             $fix_drive_relative_paths = 1;
2401             }
2402 0 0       0 }
2403 0 0       0  
2404 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2405 0         0 if ($tail eq '') {
2406             push @glob, $expr;
2407 0 0       0 next OUTER;
2408 0 0       0 }
2409 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2410 0         0 if (@globdir = _do_glob('d', $head)) {
2411             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2412             next OUTER;
2413 0 0 0     0 }
2414 0         0 }
2415             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2416 0         0 $head .= $pathsep;
2417             }
2418             $expr = $tail;
2419             }
2420 0 0       0  
2421 0 0       0 # If file component has no wildcards, we can avoid opendir
2422 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2423             if ($head eq '.') {
2424 0 0 0     0 $head = '';
2425 0         0 }
2426             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2427 0         0 $head .= $pathsep;
2428 0 0       0 }
2429 0 0       0 $head .= $expr;
2430 0         0 if ($cond eq 'd') {
2431             if (-d $head) {
2432             push @glob, $head;
2433             }
2434 0 0       0 }
2435 0         0 else {
2436             if (-e $head) {
2437             push @glob, $head;
2438 0         0 }
2439             }
2440 0 0       0 next OUTER;
2441 0         0 }
2442 0         0 opendir(*DIR, $head) or next OUTER;
2443             my @leaf = readdir DIR;
2444 0 0       0 closedir DIR;
2445 0         0  
2446             if ($head eq '.') {
2447 0 0 0     0 $head = '';
2448 0         0 }
2449             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2450             $head .= $pathsep;
2451 0         0 }
2452 0         0  
2453 0         0 my $pattern = '';
2454             while ($expr =~ / \G ($q_char) /oxgc) {
2455             my $char = $1;
2456              
2457             # 6.9. Matching Shell Globs as Regular Expressions
2458             # in Chapter 6. Pattern Matching
2459             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2460 0 0       0 # (and so on)
    0          
    0          
2461 0         0  
2462             if ($char eq '*') {
2463             $pattern .= "(?:$your_char)*",
2464 0         0 }
2465             elsif ($char eq '?') {
2466             $pattern .= "(?:$your_char)?", # DOS style
2467             # $pattern .= "(?:$your_char)", # UNIX style
2468 0         0 }
2469             elsif ((my $fc = Elatin5::fc($char)) ne $char) {
2470             $pattern .= $fc;
2471 0         0 }
2472             else {
2473             $pattern .= quotemeta $char;
2474 0     0   0 }
  0         0  
2475             }
2476             my $matchsub = sub { Elatin5::fc($_[0]) =~ /\A $pattern \z/xms };
2477              
2478             # if ($@) {
2479             # print STDERR "$0: $@\n";
2480             # next OUTER;
2481             # }
2482 0         0  
2483 0 0 0     0 INNER:
2484 0         0 for my $leaf (@leaf) {
2485             if ($leaf eq '.' or $leaf eq '..') {
2486 0 0 0     0 next INNER;
2487 0         0 }
2488             if ($cond eq 'd' and not -d "$head$leaf") {
2489             next INNER;
2490 0 0       0 }
2491 0         0  
2492 0         0 if (&$matchsub($leaf)) {
2493             push @matched, "$head$leaf";
2494             next INNER;
2495             }
2496              
2497             # [DOS compatibility special case]
2498 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2499              
2500             if (Elatin5::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2501             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2502 0 0       0 Elatin5::index($pattern,'\\.') != -1 # pattern has a dot.
2503 0         0 ) {
2504 0         0 if (&$matchsub("$leaf.")) {
2505             push @matched, "$head$leaf";
2506             next INNER;
2507             }
2508 0 0       0 }
2509 0         0 }
2510             if (@matched) {
2511             push @glob, @matched;
2512 0 0       0 }
2513 0         0 }
2514 0         0 if ($fix_drive_relative_paths) {
2515             for my $glob (@glob) {
2516             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2517 0         0 }
2518             }
2519             return @glob;
2520             }
2521              
2522             #
2523             # Latin-5 parse line
2524             #
2525 0     0   0 sub _parse_line {
2526              
2527 0         0 my($line) = @_;
2528 0         0  
2529 0         0 $line .= ' ';
2530             my @piece = ();
2531             while ($line =~ /
2532             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2533             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2534 0 0       0 /oxmsg
2535             ) {
2536 0         0 push @piece, defined($1) ? $1 : $2;
2537             }
2538             return @piece;
2539             }
2540              
2541             #
2542             # Latin-5 parse path
2543             #
2544 0     0   0 sub _parse_path {
2545              
2546 0         0 my($path,$pathsep) = @_;
2547 0         0  
2548 0         0 $path .= '/';
2549             my @subpath = ();
2550             while ($path =~ /
2551             ((?: [^\/\\] )+?) [\/\\]
2552 0         0 /oxmsg
2553             ) {
2554             push @subpath, $1;
2555 0         0 }
2556 0         0  
2557 0         0 my $tail = pop @subpath;
2558             my $head = join $pathsep, @subpath;
2559             return $head, $tail;
2560             }
2561              
2562             #
2563             # via File::HomeDir::Windows 1.00
2564             #
2565             sub my_home_MSWin32 {
2566              
2567             # A lot of unix people and unix-derived tools rely on
2568 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2569 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2570             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2571             return $ENV{'HOME'};
2572             }
2573              
2574 0         0 # Do we have a user profile?
2575             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2576             return $ENV{'USERPROFILE'};
2577             }
2578              
2579 0         0 # Some Windows use something like $ENV{'HOME'}
2580             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2581             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2582 0         0 }
2583              
2584             return undef;
2585             }
2586              
2587             #
2588             # via File::HomeDir::Unix 1.00
2589 0     0 0 0 #
2590             sub my_home {
2591 0 0 0     0 my $home;
    0 0        
2592 0         0  
2593             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2594             $home = $ENV{'HOME'};
2595             }
2596              
2597             # This is from the original code, but I'm guessing
2598 0         0 # it means "login directory" and exists on some Unixes.
2599             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2600             $home = $ENV{'LOGDIR'};
2601             }
2602              
2603             ### More-desperate methods
2604              
2605 0         0 # Light desperation on any (Unixish) platform
2606             else {
2607             $home = CORE::eval q{ (getpwuid($<))[7] };
2608             }
2609              
2610 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2611 0         0 # For example, "nobody"-like users might use /nonexistant
2612             if (defined $home and ! -d($home)) {
2613 0         0 $home = undef;
2614             }
2615             return $home;
2616             }
2617              
2618             #
2619             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2620 0     0 0 0 #
2621             sub Elatin5::PREMATCH {
2622             return $`;
2623             }
2624              
2625             #
2626             # ${^MATCH}, $MATCH, $& the string that matched
2627 0     0 0 0 #
2628             sub Elatin5::MATCH {
2629             return $&;
2630             }
2631              
2632             #
2633             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2634 0     0 0 0 #
2635             sub Elatin5::POSTMATCH {
2636             return $';
2637             }
2638              
2639             #
2640             # Latin-5 character to order (with parameter)
2641             #
2642 0 0   0 1 0 sub Latin5::ord(;$) {
2643              
2644 0 0       0 local $_ = shift if @_;
2645 0         0  
2646 0         0 if (/\A ($q_char) /oxms) {
2647 0         0 my @ord = unpack 'C*', $1;
2648 0         0 my $ord = 0;
2649             while (my $o = shift @ord) {
2650 0         0 $ord = $ord * 0x100 + $o;
2651             }
2652             return $ord;
2653 0         0 }
2654             else {
2655             return CORE::ord $_;
2656             }
2657             }
2658              
2659             #
2660             # Latin-5 character to order (without parameter)
2661             #
2662 0 0   0 0 0 sub Latin5::ord_() {
2663 0         0  
2664 0         0 if (/\A ($q_char) /oxms) {
2665 0         0 my @ord = unpack 'C*', $1;
2666 0         0 my $ord = 0;
2667             while (my $o = shift @ord) {
2668 0         0 $ord = $ord * 0x100 + $o;
2669             }
2670             return $ord;
2671 0         0 }
2672             else {
2673             return CORE::ord $_;
2674             }
2675             }
2676              
2677             #
2678             # Latin-5 reverse
2679             #
2680 0 0   0 0 0 sub Latin5::reverse(@) {
2681 0         0  
2682             if (wantarray) {
2683             return CORE::reverse @_;
2684             }
2685             else {
2686              
2687             # One of us once cornered Larry in an elevator and asked him what
2688             # problem he was solving with this, but he looked as far off into
2689             # the distance as he could in an elevator and said, "It seemed like
2690 0         0 # a good idea at the time."
2691              
2692             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2693             }
2694             }
2695              
2696             #
2697             # Latin-5 getc (with parameter, without parameter)
2698             #
2699 0     0 0 0 sub Latin5::getc(;*@) {
2700 0 0       0  
2701 0 0 0     0 my($package) = caller;
2702             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2703 0         0 croak 'Too many arguments for Latin5::getc' if @_ and not wantarray;
  0         0  
2704 0         0  
2705 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2706 0         0 my $getc = '';
2707 0 0       0 for my $length ($length[0] .. $length[-1]) {
2708 0 0       0 $getc .= CORE::getc($fh);
2709 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2710             if ($getc =~ /\A ${Elatin5::dot_s} \z/oxms) {
2711             return wantarray ? ($getc,@_) : $getc;
2712             }
2713 0 0       0 }
2714             }
2715             return wantarray ? ($getc,@_) : $getc;
2716             }
2717              
2718             #
2719             # Latin-5 length by character
2720             #
2721 0 0   0 1 0 sub Latin5::length(;$) {
2722              
2723 0         0 local $_ = shift if @_;
2724 0         0  
2725             local @_ = /\G ($q_char) /oxmsg;
2726             return scalar @_;
2727             }
2728              
2729             #
2730             # Latin-5 substr by character
2731             #
2732             BEGIN {
2733              
2734             # P.232 The lvalue Attribute
2735             # in Chapter 6: Subroutines
2736             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2737              
2738             # P.336 The lvalue Attribute
2739             # in Chapter 7: Subroutines
2740             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2741              
2742             # P.144 8.4 Lvalue subroutines
2743             # in Chapter 8: perlsub: Perl subroutines
2744 204 50 0 204 1 139722 # 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  
2745              
2746             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2747             # vv----------------------*******
2748             sub Latin5::substr($$;$$) %s {
2749              
2750             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2751              
2752             # If the substring is beyond either end of the string, substr() returns the undefined
2753             # value and produces a warning. When used as an lvalue, specifying a substring that
2754             # is entirely outside the string raises an exception.
2755             # http://perldoc.perl.org/functions/substr.html
2756              
2757             # A return with no argument returns the scalar value undef in scalar context,
2758             # an empty list () in list context, and (naturally) nothing at all in void
2759             # context.
2760              
2761             my $offset = $_[1];
2762             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2763             return;
2764             }
2765              
2766             # substr($string,$offset,$length,$replacement)
2767             if (@_ == 4) {
2768             my(undef,undef,$length,$replacement) = @_;
2769             my $substr = join '', splice(@char, $offset, $length, $replacement);
2770             $_[0] = join '', @char;
2771              
2772             # return $substr; this doesn't work, don't say "return"
2773             $substr;
2774             }
2775              
2776             # substr($string,$offset,$length)
2777             elsif (@_ == 3) {
2778             my(undef,undef,$length) = @_;
2779             my $octet_offset = 0;
2780             my $octet_length = 0;
2781             if ($offset == 0) {
2782             $octet_offset = 0;
2783             }
2784             elsif ($offset > 0) {
2785             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2786             }
2787             else {
2788             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2789             }
2790             if ($length == 0) {
2791             $octet_length = 0;
2792             }
2793             elsif ($length > 0) {
2794             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2795             }
2796             else {
2797             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2798             }
2799             CORE::substr($_[0], $octet_offset, $octet_length);
2800             }
2801              
2802             # substr($string,$offset)
2803             else {
2804             my $octet_offset = 0;
2805             if ($offset == 0) {
2806             $octet_offset = 0;
2807             }
2808             elsif ($offset > 0) {
2809             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2810             }
2811             else {
2812             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2813             }
2814             CORE::substr($_[0], $octet_offset);
2815             }
2816             }
2817             END
2818             }
2819              
2820             #
2821             # Latin-5 index by character
2822             #
2823 0     0 1 0 sub Latin5::index($$;$) {
2824 0 0       0  
2825 0         0 my $index;
2826             if (@_ == 3) {
2827             $index = Elatin5::index($_[0], $_[1], CORE::length(Latin5::substr($_[0], 0, $_[2])));
2828 0         0 }
2829             else {
2830             $index = Elatin5::index($_[0], $_[1]);
2831 0 0       0 }
2832 0         0  
2833             if ($index == -1) {
2834             return -1;
2835 0         0 }
2836             else {
2837             return Latin5::length(CORE::substr $_[0], 0, $index);
2838             }
2839             }
2840              
2841             #
2842             # Latin-5 rindex by character
2843             #
2844 0     0 1 0 sub Latin5::rindex($$;$) {
2845 0 0       0  
2846 0         0 my $rindex;
2847             if (@_ == 3) {
2848             $rindex = Elatin5::rindex($_[0], $_[1], CORE::length(Latin5::substr($_[0], 0, $_[2])));
2849 0         0 }
2850             else {
2851             $rindex = Elatin5::rindex($_[0], $_[1]);
2852 0 0       0 }
2853 0         0  
2854             if ($rindex == -1) {
2855             return -1;
2856 0         0 }
2857             else {
2858             return Latin5::length(CORE::substr $_[0], 0, $rindex);
2859             }
2860             }
2861              
2862 204     204   1978 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         737  
  204         24120  
2863             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2864             use vars qw($slash); $slash = 'm//';
2865              
2866             # ord() to ord() or Latin5::ord()
2867             my $function_ord = 'ord';
2868              
2869             # ord to ord or Latin5::ord_
2870             my $function_ord_ = 'ord';
2871              
2872             # reverse to reverse or Latin5::reverse
2873             my $function_reverse = 'reverse';
2874              
2875             # getc to getc or Latin5::getc
2876             my $function_getc = 'getc';
2877              
2878             # P.1023 Appendix W.9 Multibyte Anchoring
2879             # of ISBN 1-56592-224-7 CJKV Information Processing
2880              
2881 204     204   1454 my $anchor = '';
  204     0   413  
  204         9545194  
2882              
2883             use vars qw($nest);
2884              
2885             # regexp of nested parens in qqXX
2886              
2887             # P.340 Matching Nested Constructs with Embedded Code
2888             # in Chapter 7: Perl
2889             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2890              
2891             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2892             [^\\()] |
2893             \( (?{$nest++}) |
2894             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2895             \\ [^c] |
2896             \\c[\x40-\x5F] |
2897             [\x00-\xFF]
2898             }xms;
2899              
2900             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2901             [^\\{}] |
2902             \{ (?{$nest++}) |
2903             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2904             \\ [^c] |
2905             \\c[\x40-\x5F] |
2906             [\x00-\xFF]
2907             }xms;
2908              
2909             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2910             [^\\\[\]] |
2911             \[ (?{$nest++}) |
2912             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2913             \\ [^c] |
2914             \\c[\x40-\x5F] |
2915             [\x00-\xFF]
2916             }xms;
2917              
2918             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2919             [^\\<>] |
2920             \< (?{$nest++}) |
2921             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2922             \\ [^c] |
2923             \\c[\x40-\x5F] |
2924             [\x00-\xFF]
2925             }xms;
2926              
2927             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2928             (?: ::)? (?:
2929             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2930             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2931             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2932             ))
2933             }xms;
2934              
2935             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2936             (?: ::)? (?:
2937             (?>[0-9]+) |
2938             [^a-zA-Z_0-9\[\]] |
2939             ^[A-Z] |
2940             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2941             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2942             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2943             ))
2944             }xms;
2945              
2946             my $qq_substr = qr{(?> Char::substr | Latin5::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2947             }xms;
2948              
2949             # regexp of nested parens in qXX
2950             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2951             [^()] |
2952             \( (?{$nest++}) |
2953             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2954             [\x00-\xFF]
2955             }xms;
2956              
2957             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2958             [^\{\}] |
2959             \{ (?{$nest++}) |
2960             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2961             [\x00-\xFF]
2962             }xms;
2963              
2964             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2965             [^\[\]] |
2966             \[ (?{$nest++}) |
2967             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2968             [\x00-\xFF]
2969             }xms;
2970              
2971             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2972             [^<>] |
2973             \< (?{$nest++}) |
2974             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2975             [\x00-\xFF]
2976             }xms;
2977              
2978             my $matched = '';
2979             my $s_matched = '';
2980              
2981             my $tr_variable = ''; # variable of tr///
2982             my $sub_variable = ''; # variable of s///
2983             my $bind_operator = ''; # =~ or !~
2984              
2985             my @heredoc = (); # here document
2986             my @heredoc_delimiter = ();
2987             my $here_script = ''; # here script
2988              
2989             #
2990             # escape Latin-5 script
2991 0 50   204 0 0 #
2992             sub Latin5::escape(;$) {
2993             local($_) = $_[0] if @_;
2994              
2995             # P.359 The Study Function
2996             # in Chapter 7: Perl
2997 204         723 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2998              
2999             study $_; # Yes, I studied study yesterday.
3000              
3001             # while all script
3002              
3003             # 6.14. Matching from Where the Last Pattern Left Off
3004             # in Chapter 6. Pattern Matching
3005             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3006             # (and so on)
3007              
3008             # one member of Tag-team
3009             #
3010             # P.128 Start of match (or end of previous match): \G
3011             # P.130 Advanced Use of \G with Perl
3012             # in Chapter 3: Overview of Regular Expression Features and Flavors
3013             # P.255 Use leading anchors
3014             # P.256 Expose ^ and \G at the front expressions
3015             # in Chapter 6: Crafting an Efficient Expression
3016             # P.315 "Tag-team" matching with /gc
3017             # in Chapter 7: Perl
3018 204         397 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3019 204         393  
3020 204         709 my $e_script = '';
3021             while (not /\G \z/oxgc) { # member
3022             $e_script .= Latin5::escape_token();
3023 74693         136884 }
3024              
3025             return $e_script;
3026             }
3027              
3028             #
3029             # escape Latin-5 token of script
3030             #
3031             sub Latin5::escape_token {
3032              
3033 204     74693 0 2549 # \n output here document
3034              
3035             my $ignore_modules = join('|', qw(
3036             utf8
3037             bytes
3038             charnames
3039             I18N::Japanese
3040             I18N::Collate
3041             I18N::JExt
3042             File::DosGlob
3043             Wild
3044             Wildcard
3045             Japanese
3046             ));
3047              
3048             # another member of Tag-team
3049             #
3050             # P.315 "Tag-team" matching with /gc
3051             # in Chapter 7: Perl
3052 74693 100 100     90948 # 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          
3053 74693         3021972  
3054 12514 100       15632 if (/\G ( \n ) /oxgc) { # another member (and so on)
3055 12514         21253 my $heredoc = '';
3056             if (scalar(@heredoc_delimiter) >= 1) {
3057 174         240 $slash = 'm//';
3058 174         351  
3059             $heredoc = join '', @heredoc;
3060             @heredoc = ();
3061 174         322  
3062 174         303 # skip here document
3063             for my $heredoc_delimiter (@heredoc_delimiter) {
3064 174         1069 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3065             }
3066 174         372 @heredoc_delimiter = ();
3067              
3068 174         252 $here_script = '';
3069             }
3070             return "\n" . $heredoc;
3071             }
3072 12514         38507  
3073             # ignore space, comment
3074             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3075              
3076             # if (, elsif (, unless (, while (, until (, given (, and when (
3077              
3078             # given, when
3079              
3080             # P.225 The given Statement
3081             # in Chapter 15: Smart Matching and given-when
3082             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3083              
3084             # P.133 The given Statement
3085             # in Chapter 4: Statements and Declarations
3086             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3087 17886         55383  
3088 1401         2865 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3089             $slash = 'm//';
3090             return $1;
3091             }
3092              
3093             # scalar variable ($scalar = ...) =~ tr///;
3094             # scalar variable ($scalar = ...) =~ s///;
3095              
3096             # state
3097              
3098             # P.68 Persistent, Private Variables
3099             # in Chapter 4: Subroutines
3100             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3101              
3102             # P.160 Persistent Lexically Scoped Variables: state
3103             # in Chapter 4: Statements and Declarations
3104             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3105              
3106             # (and so on)
3107 1401         4262  
3108             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3109 86 50       230 my $e_string = e_string($1);
    50          
3110 86         2066  
3111 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3112 0         0 $tr_variable = $e_string . e_string($1);
3113 0         0 $bind_operator = $2;
3114             $slash = 'm//';
3115             return '';
3116 0         0 }
3117 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3118 0         0 $sub_variable = $e_string . e_string($1);
3119 0         0 $bind_operator = $2;
3120             $slash = 'm//';
3121             return '';
3122 0         0 }
3123 86         138 else {
3124             $slash = 'div';
3125             return $e_string;
3126             }
3127             }
3128              
3129 86         288 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
3130 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3131             $slash = 'div';
3132             return q{Elatin5::PREMATCH()};
3133             }
3134              
3135 4         15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
3136 28         54 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3137             $slash = 'div';
3138             return q{Elatin5::MATCH()};
3139             }
3140              
3141 28         91 # $', ${'} --> $', ${'}
3142 1         1 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3143             $slash = 'div';
3144             return $1;
3145             }
3146              
3147 1         5 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
3148 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3149             $slash = 'div';
3150             return q{Elatin5::POSTMATCH()};
3151             }
3152              
3153             # scalar variable $scalar =~ tr///;
3154             # scalar variable $scalar =~ s///;
3155             # substr() =~ tr///;
3156 3         10 # substr() =~ s///;
3157             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3158 1671 100       3876 my $scalar = e_string($1);
    100          
3159 1671         6521  
3160 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3161 1         2 $tr_variable = $scalar;
3162 1         2 $bind_operator = $1;
3163             $slash = 'm//';
3164             return '';
3165 1         3 }
3166 61         119 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3167 61         132 $sub_variable = $scalar;
3168 61         114 $bind_operator = $1;
3169             $slash = 'm//';
3170             return '';
3171 61         197 }
3172 1609         2414 else {
3173             $slash = 'div';
3174             return $scalar;
3175             }
3176             }
3177              
3178 1609         4405 # end of statement
3179             elsif (/\G ( [,;] ) /oxgc) {
3180             $slash = 'm//';
3181 4976         7359  
3182             # clear tr/// variable
3183             $tr_variable = '';
3184 4976         5841  
3185             # clear s/// variable
3186 4976         5348 $sub_variable = '';
3187              
3188 4976         6574 $bind_operator = '';
3189              
3190             return $1;
3191             }
3192              
3193 4976         17985 # bareword
3194             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3195             return $1;
3196             }
3197              
3198 0         0 # $0 --> $0
3199 2         9 elsif (/\G ( \$ 0 ) /oxmsgc) {
3200             $slash = 'div';
3201             return $1;
3202 2         10 }
3203 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3204             $slash = 'div';
3205             return $1;
3206             }
3207              
3208 0         0 # $$ --> $$
3209 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3210             $slash = 'div';
3211             return $1;
3212             }
3213              
3214             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3215 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3216 4         6 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3217             $slash = 'div';
3218             return e_capture($1);
3219 4         8 }
3220 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3221             $slash = 'div';
3222             return e_capture($1);
3223             }
3224              
3225 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3226 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3227             $slash = 'div';
3228             return e_capture($1.'->'.$2);
3229             }
3230              
3231 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3232 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3233             $slash = 'div';
3234             return e_capture($1.'->'.$2);
3235             }
3236              
3237 0         0 # $$foo
3238 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3239             $slash = 'div';
3240             return e_capture($1);
3241             }
3242              
3243 0         0 # ${ foo }
3244 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3245             $slash = 'div';
3246             return '${' . $1 . '}';
3247             }
3248              
3249 0         0 # ${ ... }
3250 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3251             $slash = 'div';
3252             return e_capture($1);
3253             }
3254              
3255             # variable or function
3256 0         0 # $ @ % & * $ #
3257 42         221 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) {
3258             $slash = 'div';
3259             return $1;
3260             }
3261             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3262 42         136 # $ @ # \ ' " / ? ( ) [ ] < >
3263 62         117 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3264             $slash = 'div';
3265             return $1;
3266             }
3267              
3268 62         199 # while ()
3269             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3270             return $1;
3271             }
3272              
3273             # while () --- glob
3274              
3275             # avoid "Error: Runtime exception" of perl version 5.005_03
3276 0         0  
3277             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3278             return 'while ($_ = Elatin5::glob("' . $1 . '"))';
3279             }
3280              
3281 0         0 # while (glob)
3282             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3283             return 'while ($_ = Elatin5::glob_)';
3284             }
3285              
3286 0         0 # while (glob(WILDCARD))
3287             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3288             return 'while ($_ = Elatin5::glob';
3289             }
3290 0         0  
  248         568  
3291             # doit if, doit unless, doit while, doit until, doit for, doit when
3292             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3293 248         915  
  19         48  
3294 19         83 # subroutines of package Elatin5
  0         0  
3295 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         16  
3296 13         34 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3297 0         0 elsif (/\G \b Latin5::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         243  
3298 114         311 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
3299 2         6 elsif (/\G \b Latin5::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin5::escape'; }
  0         0  
3300 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3301 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::chop'; }
  0         0  
3302 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3303 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3304 0         0 elsif (/\G \b Latin5::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin5::index'; }
  2         5  
3305 2         6 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::index'; }
  0         0  
3306 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3307 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3308 0         0 elsif (/\G \b Latin5::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin5::rindex'; }
  1         3  
3309 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::rindex'; }
  0         0  
3310 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::lc'; }
  1         3  
3311 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::lcfirst'; }
  0         0  
3312 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::uc'; }
  6         10  
3313             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::ucfirst'; }
3314             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::fc'; }
3315 6         18  
  0         0  
3316 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3317 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3318 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3319 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3320 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3321 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3322             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3323 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  
3324 0         0  
  0         0  
3325 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3326 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3327 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3328 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3329 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3330             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3331             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3332 0         0  
  0         0  
3333 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3334 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3335 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3336             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3337 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3338 2         7  
  2         5  
3339 2         5 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         57  
3340 36         108 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3341 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::chr'; }
  8         15  
3342 8         24 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3343 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3344 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::glob'; }
  0         0  
3345 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::lc_'; }
  0         0  
3346 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::lcfirst_'; }
  0         0  
3347 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::uc_'; }
  0         0  
3348 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::ucfirst_'; }
  0         0  
3349             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::fc_'; }
3350 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3351 0         0  
  0         0  
3352 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3353 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3354 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::chr_'; }
  0         0  
3355 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3356 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3357 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::glob_'; }
  8         21  
3358             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3359             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3360 8         37 # split
3361             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3362 87         176 $slash = 'm//';
3363 87         139  
3364 87         322 my $e = '';
3365             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3366             $e .= $1;
3367             }
3368 85 100       314  
  87 100       5857  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3369             # end of split
3370             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin5::split' . $e; }
3371 2         11  
3372             # split scalar value
3373             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin5::split' . $e . e_string($1); }
3374 1         5  
3375 0         0 # split literal space
3376 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin5::split' . $e . qq {qq$1 $2}; }
3377 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3378 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3379 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3380 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3381 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3382 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin5::split' . $e . qq {q$1 $2}; }
3383 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3384 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3385 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3386 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3387 10         42 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3388             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin5::split' . $e . qq {' '}; }
3389             elsif (/\G " [ ] " /oxgc) { return 'Elatin5::split' . $e . qq {" "}; }
3390              
3391 0 0       0 # split qq//
  0         0  
3392             elsif (/\G \b (qq) \b /oxgc) {
3393 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3394 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3395 0         0 while (not /\G \z/oxgc) {
3396 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3397 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3398 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3399 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3400 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3401             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3402 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3403             }
3404             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3405             }
3406             }
3407              
3408 0 50       0 # split qr//
  12         424  
3409             elsif (/\G \b (qr) \b /oxgc) {
3410 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3411 12 50       64 else {
  12 50       3142  
    50          
    50          
    50          
    50          
    50          
    50          
3412 0         0 while (not /\G \z/oxgc) {
3413 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3414 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3415 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3416 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3417 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3418 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3419             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3420 12         104 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3421             }
3422             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3423             }
3424             }
3425              
3426 0 0       0 # split q//
  0         0  
3427             elsif (/\G \b (q) \b /oxgc) {
3428 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3429 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3430 0         0 while (not /\G \z/oxgc) {
3431 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3432 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3433 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3434 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3435 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3436             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3437 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3438             }
3439             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3440             }
3441             }
3442              
3443 0 50       0 # split m//
  18         485  
3444             elsif (/\G \b (m) \b /oxgc) {
3445 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3446 18 50       77 else {
  18 50       4909  
    50          
    50          
    50          
    50          
    50          
    50          
3447 0         0 while (not /\G \z/oxgc) {
3448 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3449 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3450 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3451 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3452 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3453 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3454             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3455 18         592 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3456             }
3457             die __FILE__, ": Search pattern not terminated\n";
3458             }
3459             }
3460              
3461 0         0 # split ''
3462 0         0 elsif (/\G (\') /oxgc) {
3463 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3464 0         0 while (not /\G \z/oxgc) {
3465 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3466 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3467             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3468 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3469             }
3470             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3471             }
3472              
3473 0         0 # split ""
3474 0         0 elsif (/\G (\") /oxgc) {
3475 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3476 0         0 while (not /\G \z/oxgc) {
3477 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3478 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3479             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3480 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3481             }
3482             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3483             }
3484              
3485 0         0 # split //
3486 44         167 elsif (/\G (\/) /oxgc) {
3487 44 50       165 my $regexp = '';
  381 50       1497  
    100          
    50          
3488 0         0 while (not /\G \z/oxgc) {
3489 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3490 44         199 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3491             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3492 337         702 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3493             }
3494             die __FILE__, ": Search pattern not terminated\n";
3495             }
3496             }
3497              
3498             # tr/// or y///
3499              
3500             # about [cdsrbB]* (/B modifier)
3501             #
3502             # P.559 appendix C
3503             # of ISBN 4-89052-384-7 Programming perl
3504             # (Japanese title is: Perl puroguramingu)
3505 0         0  
3506             elsif (/\G \b ( tr | y ) \b /oxgc) {
3507             my $ope = $1;
3508 3 50       8  
3509 3         41 # $1 $2 $3 $4 $5 $6
3510 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3511             my @tr = ($tr_variable,$2);
3512             return e_tr(@tr,'',$4,$6);
3513 0         0 }
3514 3         6 else {
3515 3 50       32 my $e = '';
  3 50       226  
    50          
    50          
    50          
    50          
3516             while (not /\G \z/oxgc) {
3517 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3518 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3519 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3520 0         0 while (not /\G \z/oxgc) {
3521 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3522 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3523 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3524 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3525             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3526 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3527             }
3528             die __FILE__, ": Transliteration replacement not terminated\n";
3529 0         0 }
3530 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3531 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3532 0         0 while (not /\G \z/oxgc) {
3533 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3534 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3535 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3536 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3537             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3538 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3539             }
3540             die __FILE__, ": Transliteration replacement not terminated\n";
3541 0         0 }
3542 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3543 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3544 0         0 while (not /\G \z/oxgc) {
3545 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3546 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3547 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3548 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3549             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3550 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3551             }
3552             die __FILE__, ": Transliteration replacement not terminated\n";
3553 0         0 }
3554 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3555 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3556 0         0 while (not /\G \z/oxgc) {
3557 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3558 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3559 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3560 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3561             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3562 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3563             }
3564             die __FILE__, ": Transliteration replacement not terminated\n";
3565             }
3566 0         0 # $1 $2 $3 $4 $5 $6
3567 3         14 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3568             my @tr = ($tr_variable,$2);
3569             return e_tr(@tr,'',$4,$6);
3570 3         8 }
3571             }
3572             die __FILE__, ": Transliteration pattern not terminated\n";
3573             }
3574             }
3575              
3576 0         0 # qq//
3577             elsif (/\G \b (qq) \b /oxgc) {
3578             my $ope = $1;
3579 2180 50       5101  
3580 2180         4159 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3581 0         0 if (/\G (\#) /oxgc) { # qq# #
3582 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3583 0         0 while (not /\G \z/oxgc) {
3584 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3585 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3586             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3587 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3588             }
3589             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3590             }
3591 0         0  
3592 2180         2840 else {
3593 2180 50       5381 my $e = '';
  2180 50       10550  
    100          
    50          
    50          
    0          
3594             while (not /\G \z/oxgc) {
3595             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3596              
3597 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3598 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3599 0         0 my $qq_string = '';
3600 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3601 0         0 while (not /\G \z/oxgc) {
3602 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3603             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3604 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3605 0         0 elsif (/\G (\)) /oxgc) {
3606             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3607 0         0 else { $qq_string .= $1; }
3608             }
3609 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3610             }
3611             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3612             }
3613              
3614 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3615 2150         3277 elsif (/\G (\{) /oxgc) { # qq { }
3616 2150         2957 my $qq_string = '';
3617 2150 100       4291 local $nest = 1;
  84006 50       284929  
    100          
    100          
    50          
3618 722         1513 while (not /\G \z/oxgc) {
3619 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1579  
3620             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3621 1153 100       1903 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         4867  
3622 2150         4978 elsif (/\G (\}) /oxgc) {
3623             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3624 1153         2428 else { $qq_string .= $1; }
3625             }
3626 78828         218328 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3627             }
3628             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3629             }
3630              
3631 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3632 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3633 0         0 my $qq_string = '';
3634 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3635 0         0 while (not /\G \z/oxgc) {
3636 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3637             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3638 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3639 0         0 elsif (/\G (\]) /oxgc) {
3640             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3641 0         0 else { $qq_string .= $1; }
3642             }
3643 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3644             }
3645             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3646             }
3647              
3648 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3649 30         50 elsif (/\G (\<) /oxgc) { # qq < >
3650 30         48 my $qq_string = '';
3651 30 100       112 local $nest = 1;
  1166 50       3872  
    50          
    100          
    50          
3652 22         48 while (not /\G \z/oxgc) {
3653 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3654             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3655 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         98  
3656 30         70 elsif (/\G (\>) /oxgc) {
3657             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3658 0         0 else { $qq_string .= $1; }
3659             }
3660 1114         2044 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3661             }
3662             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3663             }
3664              
3665 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3666 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3667 0         0 my $delimiter = $1;
3668 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3669 0         0 while (not /\G \z/oxgc) {
3670 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3671 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3672             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3673 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3674             }
3675             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3676 0         0 }
3677             }
3678             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3679             }
3680             }
3681              
3682 0         0 # qr//
3683 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3684 0         0 my $ope = $1;
3685             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3686             return e_qr($ope,$1,$3,$2,$4);
3687 0         0 }
3688 0         0 else {
3689 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3690 0         0 while (not /\G \z/oxgc) {
3691 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3692 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3693 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3694 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3695 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3696 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3697             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3698 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3699             }
3700             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3701             }
3702             }
3703              
3704 0         0 # qw//
3705 16 50       288 elsif (/\G \b (qw) \b /oxgc) {
3706 16         83 my $ope = $1;
3707             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3708             return e_qw($ope,$1,$3,$2);
3709 0         0 }
3710 16         46 else {
3711 16 50       56 my $e = '';
  16 50       112  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3712             while (not /\G \z/oxgc) {
3713 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3714 16         73  
3715             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3716 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3717 0         0  
3718             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3719 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3720 0         0  
3721             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3722 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3723 0         0  
3724             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3725 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3726 0         0  
3727             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3728 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3729             }
3730             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3731             }
3732             }
3733              
3734 0         0 # qx//
3735 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3736 0         0 my $ope = $1;
3737             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3738             return e_qq($ope,$1,$3,$2);
3739 0         0 }
3740 0         0 else {
3741 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3742 0         0 while (not /\G \z/oxgc) {
3743 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3744 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3745 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3746 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3747 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3748             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3749 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3750             }
3751             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3752             }
3753             }
3754              
3755 0         0 # q//
3756             elsif (/\G \b (q) \b /oxgc) {
3757             my $ope = $1;
3758              
3759             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3760              
3761             # avoid "Error: Runtime exception" of perl version 5.005_03
3762 410 50       1234 # (and so on)
3763 410         1043  
3764 0         0 if (/\G (\#) /oxgc) { # q# #
3765 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3766 0         0 while (not /\G \z/oxgc) {
3767 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3768 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3769             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3770 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3771             }
3772             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3773             }
3774 0         0  
3775 410         718 else {
3776 410 50       1167 my $e = '';
  410 50       2027  
    100          
    50          
    100          
    50          
3777             while (not /\G \z/oxgc) {
3778             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3779              
3780 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3781 0         0 elsif (/\G (\() /oxgc) { # q ( )
3782 0         0 my $q_string = '';
3783 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3784 0         0 while (not /\G \z/oxgc) {
3785 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3786 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3787             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3788 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3789 0         0 elsif (/\G (\)) /oxgc) {
3790             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3791 0         0 else { $q_string .= $1; }
3792             }
3793 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3794             }
3795             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3796             }
3797              
3798 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3799 404         668 elsif (/\G (\{) /oxgc) { # q { }
3800 404         655 my $q_string = '';
3801 404 50       1097 local $nest = 1;
  6770 50       25310  
    50          
    100          
    100          
    50          
3802 0         0 while (not /\G \z/oxgc) {
3803 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3804 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         161  
3805             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3806 107 100       176 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1125  
3807 404         1073 elsif (/\G (\}) /oxgc) {
3808             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3809 107         213 else { $q_string .= $1; }
3810             }
3811 6152         12170 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3812             }
3813             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3814             }
3815              
3816 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3817 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3818 0         0 my $q_string = '';
3819 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3820 0         0 while (not /\G \z/oxgc) {
3821 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3822 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3823             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3824 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3825 0         0 elsif (/\G (\]) /oxgc) {
3826             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3827 0         0 else { $q_string .= $1; }
3828             }
3829 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3830             }
3831             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3832             }
3833              
3834 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3835 5         12 elsif (/\G (\<) /oxgc) { # q < >
3836 5         9 my $q_string = '';
3837 5 50       18 local $nest = 1;
  88 50       362  
    50          
    50          
    100          
    50          
3838 0         0 while (not /\G \z/oxgc) {
3839 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3840 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3841             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3842 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         13  
3843 5         17 elsif (/\G (\>) /oxgc) {
3844             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3845 0         0 else { $q_string .= $1; }
3846             }
3847 83         152 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3848             }
3849             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3850             }
3851              
3852 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3853 1         3 elsif (/\G (\S) /oxgc) { # q * *
3854 1         2 my $delimiter = $1;
3855 1 50       3 my $q_string = '';
  14 50       115  
    100          
    50          
3856 0         0 while (not /\G \z/oxgc) {
3857 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3858 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3859             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3860 13         28 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3861             }
3862             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3863 0         0 }
3864             }
3865             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3866             }
3867             }
3868              
3869 0         0 # m//
3870 209 50       495 elsif (/\G \b (m) \b /oxgc) {
3871 209         1457 my $ope = $1;
3872             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3873             return e_qr($ope,$1,$3,$2,$4);
3874 0         0 }
3875 209         334 else {
3876 209 50       591 my $e = '';
  209 50       10758  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3877 0         0 while (not /\G \z/oxgc) {
3878 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3879 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3880 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3881 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3882 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3883 10         27 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3884 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3885             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3886 199         719 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3887             }
3888             die __FILE__, ": Search pattern not terminated\n";
3889             }
3890             }
3891              
3892             # s///
3893              
3894             # about [cegimosxpradlunbB]* (/cg modifier)
3895             #
3896             # P.67 Pattern-Matching Operators
3897             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3898 0         0  
3899             elsif (/\G \b (s) \b /oxgc) {
3900             my $ope = $1;
3901 97 100       468  
3902 97         1648 # $1 $2 $3 $4 $5 $6
3903             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3904             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3905 1         6 }
3906 96         189 else {
3907 96 50       340 my $e = '';
  96 50       11958  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3908             while (not /\G \z/oxgc) {
3909 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3910 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3911 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3912             while (not /\G \z/oxgc) {
3913 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3914 0         0 # $1 $2 $3 $4
3915 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3916 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3917 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3918 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3919 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3920 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3921 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3922             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3923 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924             }
3925             die __FILE__, ": Substitution replacement not terminated\n";
3926 0         0 }
3927 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3928 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3929             while (not /\G \z/oxgc) {
3930 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3931 0         0 # $1 $2 $3 $4
3932 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941             }
3942             die __FILE__, ": Substitution replacement not terminated\n";
3943 0         0 }
3944 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3945 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3946             while (not /\G \z/oxgc) {
3947 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3948 0         0 # $1 $2 $3 $4
3949 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956             }
3957             die __FILE__, ": Substitution replacement not terminated\n";
3958 0         0 }
3959 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3960 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3961             while (not /\G \z/oxgc) {
3962 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3963 0         0 # $1 $2 $3 $4
3964 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973             }
3974             die __FILE__, ": Substitution replacement not terminated\n";
3975             }
3976 0         0 # $1 $2 $3 $4 $5 $6
3977             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3978             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3979             }
3980 21         72 # $1 $2 $3 $4 $5 $6
3981             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3982             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3983             }
3984 0         0 # $1 $2 $3 $4 $5 $6
3985             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3986             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3987             }
3988 0         0 # $1 $2 $3 $4 $5 $6
3989             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3990             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3991 75         668 }
3992             }
3993             die __FILE__, ": Substitution pattern not terminated\n";
3994             }
3995             }
3996 0         0  
3997 0         0 # require ignore module
3998 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3999             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4000             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4001 0         0  
4002 37         294 # use strict; --> use strict; no strict qw(refs);
4003 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4004             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4005             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4006              
4007 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4008 2         24 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4009             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4010             return "use $1; no strict qw(refs);";
4011 0         0 }
4012             else {
4013             return "use $1;";
4014             }
4015 2 0 0     10 }
      0        
4016 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4017             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4018             return "use $1; no strict qw(refs);";
4019 0         0 }
4020             else {
4021             return "use $1;";
4022             }
4023             }
4024 0         0  
4025 2         13 # ignore use module
4026 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4027             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4028             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4029 0         0  
4030 0         0 # ignore no module
4031 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4032             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4033             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4034 0         0  
4035             # use else
4036             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4037 0         0  
4038             # use else
4039             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4040              
4041 2         11 # ''
4042 848         1774 elsif (/\G (?
4043 848 100       2873 my $q_string = '';
  8254 100       26717  
    100          
    50          
4044 4         11 while (not /\G \z/oxgc) {
4045 48         94 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4046 848         1863 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4047             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4048 7354         15198 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4049             }
4050             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4051             }
4052              
4053 0         0 # ""
4054 1760         3709 elsif (/\G (\") /oxgc) {
4055 1760 100       5092 my $qq_string = '';
  34969 100       97540  
    100          
    50          
4056 67         152 while (not /\G \z/oxgc) {
4057 12         24 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4058 1760         3982 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4059             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4060 33130         64052 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4061             }
4062             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4063             }
4064              
4065 0         0 # ``
4066 1         3 elsif (/\G (\`) /oxgc) {
4067 1 50       4 my $qx_string = '';
  19 50       71  
    100          
    50          
4068 0         0 while (not /\G \z/oxgc) {
4069 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4070 1         2 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4071             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4072 18         28 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4073             }
4074             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4075             }
4076              
4077 0         0 # // --- not divide operator (num / num), not defined-or
4078 453         1390 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4079 453 50       1265 my $regexp = '';
  4496 50       14613  
    100          
    50          
4080 0         0 while (not /\G \z/oxgc) {
4081 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4082 453         1600 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4083             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4084 4043         9385 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4085             }
4086             die __FILE__, ": Search pattern not terminated\n";
4087             }
4088              
4089 0         0 # ?? --- not conditional operator (condition ? then : else)
4090 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4091 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4092 0         0 while (not /\G \z/oxgc) {
4093 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4094 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4095             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4096 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4097             }
4098             die __FILE__, ": Search pattern not terminated\n";
4099             }
4100 0         0  
  0         0  
4101             # <<>> (a safer ARGV)
4102             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4103 0         0  
  0         0  
4104             # << (bit shift) --- not here document
4105             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4106              
4107 0         0 # <<~'HEREDOC'
4108 6         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4109 6         11 $slash = 'm//';
4110             my $here_quote = $1;
4111             my $delimiter = $2;
4112 6 50       9  
4113 6         12 # get here document
4114 6         28 if ($here_script eq '') {
4115             $here_script = CORE::substr $_, pos $_;
4116 6 50       29 $here_script =~ s/.*?\n//oxm;
4117 6         64 }
4118 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4119 6         10 my $heredoc = $1;
4120 6         47 my $indent = $2;
4121 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4122             push @heredoc, $heredoc . qq{\n$delimiter\n};
4123             push @heredoc_delimiter, qq{\\s*$delimiter};
4124 6         11 }
4125             else {
4126 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4127             }
4128             return qq{<<'$delimiter'};
4129             }
4130              
4131             # <<~\HEREDOC
4132              
4133             # P.66 2.6.6. "Here" Documents
4134             # in Chapter 2: Bits and Pieces
4135             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4136              
4137             # P.73 "Here" Documents
4138             # in Chapter 2: Bits and Pieces
4139             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4140 6         23  
4141 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4142 3         6 $slash = 'm//';
4143             my $here_quote = $1;
4144             my $delimiter = $2;
4145 3 50       4  
4146 3         10 # get here document
4147 3         10 if ($here_script eq '') {
4148             $here_script = CORE::substr $_, pos $_;
4149 3 50       23 $here_script =~ s/.*?\n//oxm;
4150 3         39 }
4151 3         6 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4152 3         6 my $heredoc = $1;
4153 3         48 my $indent = $2;
4154 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
4155             push @heredoc, $heredoc . qq{\n$delimiter\n};
4156             push @heredoc_delimiter, qq{\\s*$delimiter};
4157 3         7 }
4158             else {
4159 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4160             }
4161             return qq{<<\\$delimiter};
4162             }
4163              
4164 3         12 # <<~"HEREDOC"
4165 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4166 6         9 $slash = 'm//';
4167             my $here_quote = $1;
4168             my $delimiter = $2;
4169 6 50       11  
4170 6         11 # get here document
4171 6         25 if ($here_script eq '') {
4172             $here_script = CORE::substr $_, pos $_;
4173 6 50       28 $here_script =~ s/.*?\n//oxm;
4174 6         52 }
4175 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4176 6         9 my $heredoc = $1;
4177 6         42 my $indent = $2;
4178 6         14 $heredoc =~ s{^$indent}{}msg; # no /ox
4179             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4180             push @heredoc_delimiter, qq{\\s*$delimiter};
4181 6         11 }
4182             else {
4183 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4184             }
4185             return qq{<<"$delimiter"};
4186             }
4187              
4188 6         21 # <<~HEREDOC
4189 3         6 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4190 3         7 $slash = 'm//';
4191             my $here_quote = $1;
4192             my $delimiter = $2;
4193 3 50       4  
4194 3         7 # get here document
4195 3         17 if ($here_script eq '') {
4196             $here_script = CORE::substr $_, pos $_;
4197 3 50       17 $here_script =~ s/.*?\n//oxm;
4198 3         38 }
4199 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4200 3         4 my $heredoc = $1;
4201 3         33 my $indent = $2;
4202 3         8 $heredoc =~ s{^$indent}{}msg; # no /ox
4203             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4204             push @heredoc_delimiter, qq{\\s*$delimiter};
4205 3         7 }
4206             else {
4207 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4208             }
4209             return qq{<<$delimiter};
4210             }
4211              
4212 3         12 # <<~`HEREDOC`
4213 6         14 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4214 6         61 $slash = 'm//';
4215             my $here_quote = $1;
4216             my $delimiter = $2;
4217 6 50       15  
4218 6         11 # get here document
4219 6         105 if ($here_script eq '') {
4220             $here_script = CORE::substr $_, pos $_;
4221 6 50       41 $here_script =~ s/.*?\n//oxm;
4222 6         128 }
4223 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4224 6         9 my $heredoc = $1;
4225 6         102 my $indent = $2;
4226 6         22 $heredoc =~ s{^$indent}{}msg; # no /ox
4227             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4228             push @heredoc_delimiter, qq{\\s*$delimiter};
4229 6         13 }
4230             else {
4231 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4232             }
4233             return qq{<<`$delimiter`};
4234             }
4235              
4236 6         26 # <<'HEREDOC'
4237 72         150 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4238 72         146 $slash = 'm//';
4239             my $here_quote = $1;
4240             my $delimiter = $2;
4241 72 50       102  
4242 72         137 # get here document
4243 72         341 if ($here_script eq '') {
4244             $here_script = CORE::substr $_, pos $_;
4245 72 50       390 $here_script =~ s/.*?\n//oxm;
4246 72         553 }
4247 72         220 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4248             push @heredoc, $1 . qq{\n$delimiter\n};
4249             push @heredoc_delimiter, $delimiter;
4250 72         113 }
4251             else {
4252 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4253             }
4254             return $here_quote;
4255             }
4256              
4257             # <<\HEREDOC
4258              
4259             # P.66 2.6.6. "Here" Documents
4260             # in Chapter 2: Bits and Pieces
4261             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4262              
4263             # P.73 "Here" Documents
4264             # in Chapter 2: Bits and Pieces
4265             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4266 72         264  
4267 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4268 0         0 $slash = 'm//';
4269             my $here_quote = $1;
4270             my $delimiter = $2;
4271 0 0       0  
4272 0         0 # get here document
4273 0         0 if ($here_script eq '') {
4274             $here_script = CORE::substr $_, pos $_;
4275 0 0       0 $here_script =~ s/.*?\n//oxm;
4276 0         0 }
4277 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4278             push @heredoc, $1 . qq{\n$delimiter\n};
4279             push @heredoc_delimiter, $delimiter;
4280 0         0 }
4281             else {
4282 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4283             }
4284             return $here_quote;
4285             }
4286              
4287 0         0 # <<"HEREDOC"
4288 36         82 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4289 36         78 $slash = 'm//';
4290             my $here_quote = $1;
4291             my $delimiter = $2;
4292 36 50       71  
4293 36         85 # get here document
4294 36         302 if ($here_script eq '') {
4295             $here_script = CORE::substr $_, pos $_;
4296 36 50       205 $here_script =~ s/.*?\n//oxm;
4297 36         456 }
4298 36         115 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4299             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4300             push @heredoc_delimiter, $delimiter;
4301 36         86 }
4302             else {
4303 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4304             }
4305             return $here_quote;
4306             }
4307              
4308 36         145 # <
4309 42         115 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4310 42         91 $slash = 'm//';
4311             my $here_quote = $1;
4312             my $delimiter = $2;
4313 42 50       74  
4314 42         116 # get here document
4315 42         324 if ($here_script eq '') {
4316             $here_script = CORE::substr $_, pos $_;
4317 42 50       328 $here_script =~ s/.*?\n//oxm;
4318 42         591 }
4319 42         218 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4320             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4321             push @heredoc_delimiter, $delimiter;
4322 42         155 }
4323             else {
4324 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4325             }
4326             return $here_quote;
4327             }
4328              
4329 42         189 # <<`HEREDOC`
4330 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4331 0         0 $slash = 'm//';
4332             my $here_quote = $1;
4333             my $delimiter = $2;
4334 0 0       0  
4335 0         0 # get here document
4336 0         0 if ($here_script eq '') {
4337             $here_script = CORE::substr $_, pos $_;
4338 0 0       0 $here_script =~ s/.*?\n//oxm;
4339 0         0 }
4340 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4341             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4342             push @heredoc_delimiter, $delimiter;
4343 0         0 }
4344             else {
4345 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4346             }
4347             return $here_quote;
4348             }
4349              
4350 0         0 # <<= <=> <= < operator
4351             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4352             return $1;
4353             }
4354              
4355 12         60 #
4356             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4357             return $1;
4358             }
4359              
4360             # --- glob
4361              
4362             # avoid "Error: Runtime exception" of perl version 5.005_03
4363 0         0  
4364             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4365             return 'Elatin5::glob("' . $1 . '")';
4366             }
4367 0         0  
4368             # __DATA__
4369             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4370 0         0  
4371             # __END__
4372             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4373              
4374             # \cD Control-D
4375              
4376             # P.68 2.6.8. Other Literal Tokens
4377             # in Chapter 2: Bits and Pieces
4378             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4379              
4380             # P.76 Other Literal Tokens
4381             # in Chapter 2: Bits and Pieces
4382 204         1423 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4383              
4384             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4385 0         0  
4386             # \cZ Control-Z
4387             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4388              
4389             # any operator before div
4390             elsif (/\G (
4391             -- | \+\+ |
4392 0         0 [\)\}\]]
  5081         10187  
4393              
4394             ) /oxgc) { $slash = 'div'; return $1; }
4395              
4396             # yada-yada or triple-dot operator
4397             elsif (/\G (
4398 5081         23321 \.\.\.
  7         13  
4399              
4400             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4401              
4402             # any operator before m//
4403              
4404             # //, //= (defined-or)
4405              
4406             # P.164 Logical Operators
4407             # in Chapter 10: More Control Structures
4408             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4409              
4410             # P.119 C-Style Logical (Short-Circuit) Operators
4411             # in Chapter 3: Unary and Binary Operators
4412             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4413              
4414             # (and so on)
4415              
4416             # ~~
4417              
4418             # P.221 The Smart Match Operator
4419             # in Chapter 15: Smart Matching and given-when
4420             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4421              
4422             # P.112 Smartmatch Operator
4423             # in Chapter 3: Unary and Binary Operators
4424             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4425              
4426             # (and so on)
4427              
4428             elsif (/\G ((?>
4429              
4430             !~~ | !~ | != | ! |
4431             %= | % |
4432             &&= | && | &= | &\.= | &\. | & |
4433             -= | -> | - |
4434             :(?>\s*)= |
4435             : |
4436             <<>> |
4437             <<= | <=> | <= | < |
4438             == | => | =~ | = |
4439             >>= | >> | >= | > |
4440             \*\*= | \*\* | \*= | \* |
4441             \+= | \+ |
4442             \.\. | \.= | \. |
4443             \/\/= | \/\/ |
4444             \/= | \/ |
4445             \? |
4446             \\ |
4447             \^= | \^\.= | \^\. | \^ |
4448             \b x= |
4449             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4450             ~~ | ~\. | ~ |
4451             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4452             \b(?: print )\b |
4453              
4454 7         24 [,;\(\{\[]
  8824         17246  
4455              
4456             )) /oxgc) { $slash = 'm//'; return $1; }
4457 8824         39590  
  15137         28165  
4458             # other any character
4459             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4460              
4461 15137         85083 # system error
4462             else {
4463             die __FILE__, ": Oops, this shouldn't happen!\n";
4464             }
4465             }
4466              
4467 0     1786 0 0 # escape Latin-5 string
4468 1786         4659 sub e_string {
4469             my($string) = @_;
4470 1786         2744 my $e_string = '';
4471              
4472             local $slash = 'm//';
4473              
4474             # P.1024 Appendix W.10 Multibyte Processing
4475             # of ISBN 1-56592-224-7 CJKV Information Processing
4476 1786         2473 # (and so on)
4477              
4478             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4479 1786 100 66     14243  
4480 1786 50       7279 # without { ... }
4481 1769         4339 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4482             if ($string !~ /<
4483             return $string;
4484             }
4485             }
4486 1769         4474  
4487 17 50       49 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          
4488             while ($string !~ /\G \z/oxgc) {
4489             if (0) {
4490             }
4491 190         11708  
4492 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin5::PREMATCH()]}
4493 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4494             $e_string .= q{Elatin5::PREMATCH()};
4495             $slash = 'div';
4496             }
4497              
4498 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin5::MATCH()]}
4499 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4500             $e_string .= q{Elatin5::MATCH()};
4501             $slash = 'div';
4502             }
4503              
4504 0         0 # $', ${'} --> $', ${'}
4505 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4506             $e_string .= $1;
4507             $slash = 'div';
4508             }
4509              
4510 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin5::POSTMATCH()]}
4511 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4512             $e_string .= q{Elatin5::POSTMATCH()};
4513             $slash = 'div';
4514             }
4515              
4516 0         0 # bareword
4517 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4518             $e_string .= $1;
4519             $slash = 'div';
4520             }
4521              
4522 0         0 # $0 --> $0
4523 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4524             $e_string .= $1;
4525             $slash = 'div';
4526 0         0 }
4527 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4528             $e_string .= $1;
4529             $slash = 'div';
4530             }
4531              
4532 0         0 # $$ --> $$
4533 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4534             $e_string .= $1;
4535             $slash = 'div';
4536             }
4537              
4538             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4539 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4540 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4541             $e_string .= e_capture($1);
4542             $slash = 'div';
4543 0         0 }
4544 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4545             $e_string .= e_capture($1);
4546             $slash = 'div';
4547             }
4548              
4549 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4550 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4551             $e_string .= e_capture($1.'->'.$2);
4552             $slash = 'div';
4553             }
4554              
4555 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4556 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4557             $e_string .= e_capture($1.'->'.$2);
4558             $slash = 'div';
4559             }
4560              
4561 0         0 # $$foo
4562 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4563             $e_string .= e_capture($1);
4564             $slash = 'div';
4565             }
4566              
4567 0         0 # ${ foo }
4568 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4569             $e_string .= '${' . $1 . '}';
4570             $slash = 'div';
4571             }
4572              
4573 0         0 # ${ ... }
4574 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4575             $e_string .= e_capture($1);
4576             $slash = 'div';
4577             }
4578              
4579             # variable or function
4580 3         13 # $ @ % & * $ #
4581 7         29 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) {
4582             $e_string .= $1;
4583             $slash = 'div';
4584             }
4585             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4586 7         25 # $ @ # \ ' " / ? ( ) [ ] < >
4587 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4588             $e_string .= $1;
4589             $slash = 'div';
4590             }
4591 0         0  
  0         0  
4592 0         0 # subroutines of package Elatin5
  0         0  
4593 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4594 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4595 0         0 elsif ($string =~ /\G \b Latin5::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4596 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4597 0         0 elsif ($string =~ /\G \b Latin5::eval \b /oxgc) { $e_string .= 'eval Latin5::escape'; $slash = 'm//'; }
  0         0  
4598 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4599 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin5::chop'; $slash = 'm//'; }
  0         0  
4600 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4601 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4602 0         0 elsif ($string =~ /\G \b Latin5::index \b /oxgc) { $e_string .= 'Latin5::index'; $slash = 'm//'; }
  0         0  
4603 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin5::index'; $slash = 'm//'; }
  0         0  
4604 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4605 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4606 0         0 elsif ($string =~ /\G \b Latin5::rindex \b /oxgc) { $e_string .= 'Latin5::rindex'; $slash = 'm//'; }
  0         0  
4607 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin5::rindex'; $slash = 'm//'; }
  0         0  
4608 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::lc'; $slash = 'm//'; }
  0         0  
4609 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::lcfirst'; $slash = 'm//'; }
  0         0  
4610 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::uc'; $slash = 'm//'; }
  0         0  
4611             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::ucfirst'; $slash = 'm//'; }
4612             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::fc'; $slash = 'm//'; }
4613 0         0  
  0         0  
4614 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4615 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4616 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  
4617 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  
4618 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  
4619 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  
4620             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4621 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  
4622 0         0  
  0         0  
4623 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4624 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  
4625 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  
4626 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  
4627 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  
4628             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4629             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4630 0         0  
  0         0  
4631 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4632 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4633 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4634             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4635 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4636 0         0  
  0         0  
4637 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4638 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4639 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::chr'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4641 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4642 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::glob'; $slash = 'm//'; }
  0         0  
4643 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin5::lc_'; $slash = 'm//'; }
  0         0  
4644 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin5::lcfirst_'; $slash = 'm//'; }
  0         0  
4645 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin5::uc_'; $slash = 'm//'; }
  0         0  
4646 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin5::ucfirst_'; $slash = 'm//'; }
  0         0  
4647             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin5::fc_'; $slash = 'm//'; }
4648 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4649 0         0  
  0         0  
4650 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4651 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4652 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin5::chr_'; $slash = 'm//'; }
  0         0  
4653 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4654 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4655 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin5::glob_'; $slash = 'm//'; }
  0         0  
4656             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4657             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4658 0         0 # split
4659             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4660 0         0 $slash = 'm//';
4661 0         0  
4662 0         0 my $e = '';
4663             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4664             $e .= $1;
4665             }
4666 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4667             # end of split
4668             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin5::split' . $e; }
4669 0         0  
  0         0  
4670             # split scalar value
4671             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin5::split' . $e . e_string($1); next E_STRING_LOOP; }
4672 0         0  
  0         0  
4673 0         0 # split literal space
  0         0  
4674 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4677 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4678 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4679 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  
4680 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4681 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4682 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4683 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4684 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4685 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  
4686             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {' '}; next E_STRING_LOOP; }
4687             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {" "}; next E_STRING_LOOP; }
4688              
4689 0 0       0 # split qq//
  0         0  
  0         0  
4690             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4691 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4692 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4693 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4694 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4695 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  
4696 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  
4697 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  
4698 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  
4699             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4700 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 * *
4701             }
4702             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4703             }
4704             }
4705              
4706 0 0       0 # split qr//
  0         0  
  0         0  
4707             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4708 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4709 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4710 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4711 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4712 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  
4713 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  
4714 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  
4715 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  
4716 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  
4717             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4718 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 * *
4719             }
4720             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4721             }
4722             }
4723              
4724 0 0       0 # split q//
  0         0  
  0         0  
4725             elsif ($string =~ /\G \b (q) \b /oxgc) {
4726 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4727 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4728 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4729 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4730 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4731 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  
4732 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  
4733 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  
4734             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4735 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 * *
4736             }
4737             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4738             }
4739             }
4740              
4741 0 0       0 # split m//
  0         0  
  0         0  
4742             elsif ($string =~ /\G \b (m) \b /oxgc) {
4743 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 # #
4744 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4745 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4746 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4747 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  
4748 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  
4749 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  
4750 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  
4751 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  
4752             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4753 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 * *
4754             }
4755             die __FILE__, ": Search pattern not terminated\n";
4756             }
4757             }
4758              
4759 0         0 # split ''
4760 0         0 elsif ($string =~ /\G (\') /oxgc) {
4761 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4762 0         0 while ($string !~ /\G \z/oxgc) {
4763 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4764 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4765             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4766 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4767             }
4768             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4769             }
4770              
4771 0         0 # split ""
4772 0         0 elsif ($string =~ /\G (\") /oxgc) {
4773 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4774 0         0 while ($string !~ /\G \z/oxgc) {
4775 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4776 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4777             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4778 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4779             }
4780             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4781             }
4782              
4783 0         0 # split //
4784 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4785 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4786 0         0 while ($string !~ /\G \z/oxgc) {
4787 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4788 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4789             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4790 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4791             }
4792             die __FILE__, ": Search pattern not terminated\n";
4793             }
4794             }
4795              
4796 0         0 # qq//
4797 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4798 0         0 my $ope = $1;
4799             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4800             $e_string .= e_qq($ope,$1,$3,$2);
4801 0         0 }
4802 0         0 else {
4803 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4804 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4805 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4806 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4807 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4808 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4809             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4810 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4811             }
4812             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4813             }
4814             }
4815              
4816 0         0 # qx//
4817 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4818 0         0 my $ope = $1;
4819             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4820             $e_string .= e_qq($ope,$1,$3,$2);
4821 0         0 }
4822 0         0 else {
4823 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4824 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4825 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4826 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4827 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4828 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4829 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4830             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4831 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4832             }
4833             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4834             }
4835             }
4836              
4837 0         0 # q//
4838 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4839 0         0 my $ope = $1;
4840             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4841             $e_string .= e_q($ope,$1,$3,$2);
4842 0         0 }
4843 0         0 else {
4844 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4845 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4846 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4847 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4848 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4849 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4850             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4851 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 * *
4852             }
4853             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4854             }
4855             }
4856 0         0  
4857             # ''
4858             elsif ($string =~ /\G (?
4859 0         0  
4860             # ""
4861             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4862 0         0  
4863             # ``
4864             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4865 0         0  
4866             # <<>> (a safer ARGV)
4867             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4868 0         0  
4869             # <<= <=> <= < operator
4870             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4871 0         0  
4872             #
4873             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4874              
4875 0         0 # --- glob
4876             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4877             $e_string .= 'Elatin5::glob("' . $1 . '")';
4878             }
4879              
4880 0         0 # << (bit shift) --- not here document
4881 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4882             $slash = 'm//';
4883             $e_string .= $1;
4884             }
4885              
4886 0         0 # <<~'HEREDOC'
4887 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4888 0         0 $slash = 'm//';
4889             my $here_quote = $1;
4890             my $delimiter = $2;
4891 0 0       0  
4892 0         0 # get here document
4893 0         0 if ($here_script eq '') {
4894             $here_script = CORE::substr $_, pos $_;
4895 0 0       0 $here_script =~ s/.*?\n//oxm;
4896 0         0 }
4897 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4898 0         0 my $heredoc = $1;
4899 0         0 my $indent = $2;
4900 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4901             push @heredoc, $heredoc . qq{\n$delimiter\n};
4902             push @heredoc_delimiter, qq{\\s*$delimiter};
4903 0         0 }
4904             else {
4905 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4906             }
4907             $e_string .= qq{<<'$delimiter'};
4908             }
4909              
4910 0         0 # <<~\HEREDOC
4911 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4912 0         0 $slash = 'm//';
4913             my $here_quote = $1;
4914             my $delimiter = $2;
4915 0 0       0  
4916 0         0 # get here document
4917 0         0 if ($here_script eq '') {
4918             $here_script = CORE::substr $_, pos $_;
4919 0 0       0 $here_script =~ s/.*?\n//oxm;
4920 0         0 }
4921 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4922 0         0 my $heredoc = $1;
4923 0         0 my $indent = $2;
4924 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4925             push @heredoc, $heredoc . qq{\n$delimiter\n};
4926             push @heredoc_delimiter, qq{\\s*$delimiter};
4927 0         0 }
4928             else {
4929 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4930             }
4931             $e_string .= qq{<<\\$delimiter};
4932             }
4933              
4934 0         0 # <<~"HEREDOC"
4935 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4936 0         0 $slash = 'm//';
4937             my $here_quote = $1;
4938             my $delimiter = $2;
4939 0 0       0  
4940 0         0 # get here document
4941 0         0 if ($here_script eq '') {
4942             $here_script = CORE::substr $_, pos $_;
4943 0 0       0 $here_script =~ s/.*?\n//oxm;
4944 0         0 }
4945 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4946 0         0 my $heredoc = $1;
4947 0         0 my $indent = $2;
4948 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4949             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4950             push @heredoc_delimiter, qq{\\s*$delimiter};
4951 0         0 }
4952             else {
4953 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4954             }
4955             $e_string .= qq{<<"$delimiter"};
4956             }
4957              
4958 0         0 # <<~HEREDOC
4959 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4960 0         0 $slash = 'm//';
4961             my $here_quote = $1;
4962             my $delimiter = $2;
4963 0 0       0  
4964 0         0 # get here document
4965 0         0 if ($here_script eq '') {
4966             $here_script = CORE::substr $_, pos $_;
4967 0 0       0 $here_script =~ s/.*?\n//oxm;
4968 0         0 }
4969 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4970 0         0 my $heredoc = $1;
4971 0         0 my $indent = $2;
4972 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4973             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4974             push @heredoc_delimiter, qq{\\s*$delimiter};
4975 0         0 }
4976             else {
4977 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4978             }
4979             $e_string .= qq{<<$delimiter};
4980             }
4981              
4982 0         0 # <<~`HEREDOC`
4983 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4984 0         0 $slash = 'm//';
4985             my $here_quote = $1;
4986             my $delimiter = $2;
4987 0 0       0  
4988 0         0 # get here document
4989 0         0 if ($here_script eq '') {
4990             $here_script = CORE::substr $_, pos $_;
4991 0 0       0 $here_script =~ s/.*?\n//oxm;
4992 0         0 }
4993 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4994 0         0 my $heredoc = $1;
4995 0         0 my $indent = $2;
4996 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4997             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4998             push @heredoc_delimiter, qq{\\s*$delimiter};
4999 0         0 }
5000             else {
5001 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5002             }
5003             $e_string .= qq{<<`$delimiter`};
5004             }
5005              
5006 0         0 # <<'HEREDOC'
5007 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5008 0         0 $slash = 'm//';
5009             my $here_quote = $1;
5010             my $delimiter = $2;
5011 0 0       0  
5012 0         0 # get here document
5013 0         0 if ($here_script eq '') {
5014             $here_script = CORE::substr $_, pos $_;
5015 0 0       0 $here_script =~ s/.*?\n//oxm;
5016 0         0 }
5017 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5018             push @heredoc, $1 . qq{\n$delimiter\n};
5019             push @heredoc_delimiter, $delimiter;
5020 0         0 }
5021             else {
5022 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5023             }
5024             $e_string .= $here_quote;
5025             }
5026              
5027 0         0 # <<\HEREDOC
5028 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5029 0         0 $slash = 'm//';
5030             my $here_quote = $1;
5031             my $delimiter = $2;
5032 0 0       0  
5033 0         0 # get here document
5034 0         0 if ($here_script eq '') {
5035             $here_script = CORE::substr $_, pos $_;
5036 0 0       0 $here_script =~ s/.*?\n//oxm;
5037 0         0 }
5038 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5039             push @heredoc, $1 . qq{\n$delimiter\n};
5040             push @heredoc_delimiter, $delimiter;
5041 0         0 }
5042             else {
5043 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5044             }
5045             $e_string .= $here_quote;
5046             }
5047              
5048 0         0 # <<"HEREDOC"
5049 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5050 0         0 $slash = 'm//';
5051             my $here_quote = $1;
5052             my $delimiter = $2;
5053 0 0       0  
5054 0         0 # get here document
5055 0         0 if ($here_script eq '') {
5056             $here_script = CORE::substr $_, pos $_;
5057 0 0       0 $here_script =~ s/.*?\n//oxm;
5058 0         0 }
5059 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5060             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5061             push @heredoc_delimiter, $delimiter;
5062 0         0 }
5063             else {
5064 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5065             }
5066             $e_string .= $here_quote;
5067             }
5068              
5069 0         0 # <
5070 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5071 0         0 $slash = 'm//';
5072             my $here_quote = $1;
5073             my $delimiter = $2;
5074 0 0       0  
5075 0         0 # get here document
5076 0         0 if ($here_script eq '') {
5077             $here_script = CORE::substr $_, pos $_;
5078 0 0       0 $here_script =~ s/.*?\n//oxm;
5079 0         0 }
5080 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5081             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5082             push @heredoc_delimiter, $delimiter;
5083 0         0 }
5084             else {
5085 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5086             }
5087             $e_string .= $here_quote;
5088             }
5089              
5090 0         0 # <<`HEREDOC`
5091 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5092 0         0 $slash = 'm//';
5093             my $here_quote = $1;
5094             my $delimiter = $2;
5095 0 0       0  
5096 0         0 # get here document
5097 0         0 if ($here_script eq '') {
5098             $here_script = CORE::substr $_, pos $_;
5099 0 0       0 $here_script =~ s/.*?\n//oxm;
5100 0         0 }
5101 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5102             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5103             push @heredoc_delimiter, $delimiter;
5104 0         0 }
5105             else {
5106 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5107             }
5108             $e_string .= $here_quote;
5109             }
5110              
5111             # any operator before div
5112             elsif ($string =~ /\G (
5113             -- | \+\+ |
5114 0         0 [\)\}\]]
  18         34  
5115              
5116             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5117              
5118             # yada-yada or triple-dot operator
5119             elsif ($string =~ /\G (
5120 18         57 \.\.\.
  0         0  
5121              
5122             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5123              
5124             # any operator before m//
5125             elsif ($string =~ /\G ((?>
5126              
5127             !~~ | !~ | != | ! |
5128             %= | % |
5129             &&= | && | &= | &\.= | &\. | & |
5130             -= | -> | - |
5131             :(?>\s*)= |
5132             : |
5133             <<>> |
5134             <<= | <=> | <= | < |
5135             == | => | =~ | = |
5136             >>= | >> | >= | > |
5137             \*\*= | \*\* | \*= | \* |
5138             \+= | \+ |
5139             \.\. | \.= | \. |
5140             \/\/= | \/\/ |
5141             \/= | \/ |
5142             \? |
5143             \\ |
5144             \^= | \^\.= | \^\. | \^ |
5145             \b x= |
5146             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5147             ~~ | ~\. | ~ |
5148             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5149             \b(?: print )\b |
5150              
5151 0         0 [,;\(\{\[]
  31         57  
5152              
5153             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5154 31         126  
5155             # other any character
5156             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5157              
5158 131         343 # system error
5159             else {
5160             die __FILE__, ": Oops, this shouldn't happen!\n";
5161             }
5162 0         0 }
5163              
5164             return $e_string;
5165             }
5166              
5167             #
5168             # character class
5169 17     1919 0 85 #
5170             sub character_class {
5171 1919 100       3693 my($char,$modifier) = @_;
5172 1919 100       3076  
5173 52         95 if ($char eq '.') {
5174             if ($modifier =~ /s/) {
5175             return '${Elatin5::dot_s}';
5176 17         36 }
5177             else {
5178             return '${Elatin5::dot}';
5179             }
5180 35         70 }
5181             else {
5182             return Elatin5::classic_character_class($char);
5183             }
5184             }
5185              
5186             #
5187             # escape capture ($1, $2, $3, ...)
5188             #
5189 1867     212 0 3428 sub e_capture {
5190              
5191             return join '', '${', $_[0], '}';
5192             }
5193              
5194             #
5195             # escape transliteration (tr/// or y///)
5196 212     3 0 725 #
5197 3         18 sub e_tr {
5198 3   50     12 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5199             my $e_tr = '';
5200 3         6 $modifier ||= '';
5201              
5202             $slash = 'div';
5203 3         5  
5204             # quote character class 1
5205             $charclass = q_tr($charclass);
5206 3         6  
5207             # quote character class 2
5208             $charclass2 = q_tr($charclass2);
5209 3 50       6  
5210 3 0       8 # /b /B modifier
5211 0         0 if ($modifier =~ tr/bB//d) {
5212             if ($variable eq '') {
5213             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5214 0         0 }
5215             else {
5216             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5217             }
5218 0 100       0 }
5219 3         7 else {
5220             if ($variable eq '') {
5221             $e_tr = qq{Elatin5::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5222 2         7 }
5223             else {
5224             $e_tr = qq{Elatin5::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5225             }
5226             }
5227 1         5  
5228 3         5 # clear tr/// variable
5229             $tr_variable = '';
5230 3         4 $bind_operator = '';
5231              
5232             return $e_tr;
5233             }
5234              
5235             #
5236             # quote for escape transliteration (tr/// or y///)
5237 3     6 0 14 #
5238             sub q_tr {
5239             my($charclass) = @_;
5240 6 50       9  
    0          
    0          
    0          
    0          
    0          
5241 6         14 # quote character class
5242             if ($charclass !~ /'/oxms) {
5243             return e_q('', "'", "'", $charclass); # --> q' '
5244 6         9 }
5245             elsif ($charclass !~ /\//oxms) {
5246             return e_q('q', '/', '/', $charclass); # --> q/ /
5247 0         0 }
5248             elsif ($charclass !~ /\#/oxms) {
5249             return e_q('q', '#', '#', $charclass); # --> q# #
5250 0         0 }
5251             elsif ($charclass !~ /[\<\>]/oxms) {
5252             return e_q('q', '<', '>', $charclass); # --> q< >
5253 0         0 }
5254             elsif ($charclass !~ /[\(\)]/oxms) {
5255             return e_q('q', '(', ')', $charclass); # --> q( )
5256 0         0 }
5257             elsif ($charclass !~ /[\{\}]/oxms) {
5258             return e_q('q', '{', '}', $charclass); # --> q{ }
5259 0         0 }
5260 0 0       0 else {
5261 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5262             if ($charclass !~ /\Q$char\E/xms) {
5263             return e_q('q', $char, $char, $charclass);
5264             }
5265             }
5266 0         0 }
5267              
5268             return e_q('q', '{', '}', $charclass);
5269             }
5270              
5271             #
5272             # escape q string (q//, '')
5273 0     1264 0 0 #
5274             sub e_q {
5275 1264         3334 my($ope,$delimiter,$end_delimiter,$string) = @_;
5276              
5277 1264         1763 $slash = 'div';
5278              
5279             return join '', $ope, $delimiter, $string, $end_delimiter;
5280             }
5281              
5282             #
5283             # escape qq string (qq//, "", qx//, ``)
5284 1264     4022 0 7239 #
5285             sub e_qq {
5286 4022         9612 my($ope,$delimiter,$end_delimiter,$string) = @_;
5287              
5288 4022         7357 $slash = 'div';
5289 4022         5038  
5290             my $left_e = 0;
5291             my $right_e = 0;
5292 4022         6324  
5293             # split regexp
5294             my @char = $string =~ /\G((?>
5295             [^\\\$] |
5296             \\x\{ (?>[0-9A-Fa-f]+) \} |
5297             \\o\{ (?>[0-7]+) \} |
5298             \\N\{ (?>[^0-9\}][^\}]*) \} |
5299             \\ $q_char |
5300             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5301             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5302             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5303             \$ (?>\s* [0-9]+) |
5304             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5305             \$ \$ (?![\w\{]) |
5306             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5307             $q_char
5308 4022         136912 ))/oxmsg;
5309              
5310             for (my $i=0; $i <= $#char; $i++) {
5311 4022 50 33     12473  
    50 33        
    100          
    100          
    50          
5312 113709         390327 # "\L\u" --> "\u\L"
5313             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5314             @char[$i,$i+1] = @char[$i+1,$i];
5315             }
5316              
5317 0         0 # "\U\l" --> "\l\U"
5318             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5319             @char[$i,$i+1] = @char[$i+1,$i];
5320             }
5321              
5322 0         0 # octal escape sequence
5323             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5324             $char[$i] = Elatin5::octchr($1);
5325             }
5326              
5327 1         3 # hexadecimal escape sequence
5328             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5329             $char[$i] = Elatin5::hexchr($1);
5330             }
5331              
5332 1         3 # \N{CHARNAME} --> N{CHARNAME}
5333             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5334             $char[$i] = $1;
5335 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          
5336              
5337             if (0) {
5338             }
5339              
5340             # \F
5341             #
5342             # P.69 Table 2-6. Translation escapes
5343             # in Chapter 2: Bits and Pieces
5344             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5345             # (and so on)
5346 113709         1007884  
5347 0 50       0 # \u \l \U \L \F \Q \E
5348 484         1073 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5349             if ($right_e < $left_e) {
5350             $char[$i] = '\\' . $char[$i];
5351             }
5352             }
5353             elsif ($char[$i] eq '\u') {
5354              
5355             # "STRING @{[ LIST EXPR ]} MORE STRING"
5356              
5357             # P.257 Other Tricks You Can Do with Hard References
5358             # in Chapter 8: References
5359             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5360              
5361             # P.353 Other Tricks You Can Do with Hard References
5362             # in Chapter 8: References
5363             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5364              
5365 0         0 # (and so on)
5366 0         0  
5367             $char[$i] = '@{[Elatin5::ucfirst qq<';
5368             $left_e++;
5369 0         0 }
5370 0         0 elsif ($char[$i] eq '\l') {
5371             $char[$i] = '@{[Elatin5::lcfirst qq<';
5372             $left_e++;
5373 0         0 }
5374 0         0 elsif ($char[$i] eq '\U') {
5375             $char[$i] = '@{[Elatin5::uc qq<';
5376             $left_e++;
5377 0         0 }
5378 0         0 elsif ($char[$i] eq '\L') {
5379             $char[$i] = '@{[Elatin5::lc qq<';
5380             $left_e++;
5381 0         0 }
5382 24         39 elsif ($char[$i] eq '\F') {
5383             $char[$i] = '@{[Elatin5::fc qq<';
5384             $left_e++;
5385 24         1643 }
5386 0         0 elsif ($char[$i] eq '\Q') {
5387             $char[$i] = '@{[CORE::quotemeta qq<';
5388             $left_e++;
5389 0 50       0 }
5390 24         46 elsif ($char[$i] eq '\E') {
5391 24         36 if ($right_e < $left_e) {
5392             $char[$i] = '>]}';
5393             $right_e++;
5394 24         44 }
5395             else {
5396             $char[$i] = '';
5397             }
5398 0         0 }
5399 0 0       0 elsif ($char[$i] eq '\Q') {
5400 0         0 while (1) {
5401             if (++$i > $#char) {
5402 0 0       0 last;
5403 0         0 }
5404             if ($char[$i] eq '\E') {
5405             last;
5406             }
5407             }
5408             }
5409             elsif ($char[$i] eq '\E') {
5410             }
5411              
5412             # $0 --> $0
5413             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5414             }
5415             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5416             }
5417              
5418             # $$ --> $$
5419             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5420             }
5421              
5422             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5423 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5424             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5425             $char[$i] = e_capture($1);
5426 205         382 }
5427             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5428             $char[$i] = e_capture($1);
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_bracket)*? \] ) \z/oxms) {
5433             $char[$i] = e_capture($1.'->'.$2);
5434             }
5435              
5436 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5437             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5438             $char[$i] = e_capture($1.'->'.$2);
5439             }
5440              
5441 0         0 # $$foo
5442             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5443             $char[$i] = e_capture($1);
5444             }
5445              
5446 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
5447             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5448             $char[$i] = '@{[Elatin5::PREMATCH()]}';
5449             }
5450              
5451 44         119 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
5452             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5453             $char[$i] = '@{[Elatin5::MATCH()]}';
5454             }
5455              
5456 45         141 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
5457             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5458             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
5459             }
5460              
5461             # ${ foo } --> ${ foo }
5462             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5463             }
5464              
5465 33         94 # ${ ... }
5466             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5467             $char[$i] = e_capture($1);
5468             }
5469             }
5470 0 50       0  
5471 4022         7797 # return string
5472             if ($left_e > $right_e) {
5473 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5474             }
5475             return join '', $ope, $delimiter, @char, $end_delimiter;
5476             }
5477              
5478             #
5479             # escape qw string (qw//)
5480 4022     16 0 33864 #
5481             sub e_qw {
5482 16         81 my($ope,$delimiter,$end_delimiter,$string) = @_;
5483              
5484             $slash = 'div';
5485 16         31  
  16         207  
5486 483 50       717 # choice again delimiter
    0          
    0          
    0          
    0          
5487 16         90 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5488             if (not $octet{$end_delimiter}) {
5489             return join '', $ope, $delimiter, $string, $end_delimiter;
5490 16         117 }
5491             elsif (not $octet{')'}) {
5492             return join '', $ope, '(', $string, ')';
5493 0         0 }
5494             elsif (not $octet{'}'}) {
5495             return join '', $ope, '{', $string, '}';
5496 0         0 }
5497             elsif (not $octet{']'}) {
5498             return join '', $ope, '[', $string, ']';
5499 0         0 }
5500             elsif (not $octet{'>'}) {
5501             return join '', $ope, '<', $string, '>';
5502 0         0 }
5503 0 0       0 else {
5504 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5505             if (not $octet{$char}) {
5506             return join '', $ope, $char, $string, $char;
5507             }
5508             }
5509             }
5510 0         0  
5511 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5512 0         0 my @string = CORE::split(/\s+/, $string);
5513 0         0 for my $string (@string) {
5514 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5515 0         0 for my $octet (@octet) {
5516             if ($octet =~ /\A (['\\]) \z/oxms) {
5517             $octet = '\\' . $1;
5518 0         0 }
5519             }
5520 0         0 $string = join '', @octet;
  0         0  
5521             }
5522             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5523             }
5524              
5525             #
5526             # escape here document (<<"HEREDOC", <
5527 0     93 0 0 #
5528             sub e_heredoc {
5529 93         245 my($string) = @_;
5530              
5531 93         140 $slash = 'm//';
5532              
5533 93         310 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5534 93         124  
5535             my $left_e = 0;
5536             my $right_e = 0;
5537 93         121  
5538             # split regexp
5539             my @char = $string =~ /\G((?>
5540             [^\\\$] |
5541             \\x\{ (?>[0-9A-Fa-f]+) \} |
5542             \\o\{ (?>[0-7]+) \} |
5543             \\N\{ (?>[^0-9\}][^\}]*) \} |
5544             \\ $q_char |
5545             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5546             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5547             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5548             \$ (?>\s* [0-9]+) |
5549             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5550             \$ \$ (?![\w\{]) |
5551             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5552             $q_char
5553 93         9005 ))/oxmsg;
5554              
5555             for (my $i=0; $i <= $#char; $i++) {
5556 93 50 33     408  
    50 33        
    100          
    100          
    50          
5557 3177         10063 # "\L\u" --> "\u\L"
5558             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5559             @char[$i,$i+1] = @char[$i+1,$i];
5560             }
5561              
5562 0         0 # "\U\l" --> "\l\U"
5563             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5564             @char[$i,$i+1] = @char[$i+1,$i];
5565             }
5566              
5567 0         0 # octal escape sequence
5568             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5569             $char[$i] = Elatin5::octchr($1);
5570             }
5571              
5572 1         3 # hexadecimal escape sequence
5573             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5574             $char[$i] = Elatin5::hexchr($1);
5575             }
5576              
5577 1         3 # \N{CHARNAME} --> N{CHARNAME}
5578             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5579             $char[$i] = $1;
5580 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          
5581              
5582             if (0) {
5583             }
5584 3177         26808  
5585 0 0       0 # \u \l \U \L \F \Q \E
5586 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5587             if ($right_e < $left_e) {
5588             $char[$i] = '\\' . $char[$i];
5589             }
5590 0         0 }
5591 0         0 elsif ($char[$i] eq '\u') {
5592             $char[$i] = '@{[Elatin5::ucfirst qq<';
5593             $left_e++;
5594 0         0 }
5595 0         0 elsif ($char[$i] eq '\l') {
5596             $char[$i] = '@{[Elatin5::lcfirst qq<';
5597             $left_e++;
5598 0         0 }
5599 0         0 elsif ($char[$i] eq '\U') {
5600             $char[$i] = '@{[Elatin5::uc qq<';
5601             $left_e++;
5602 0         0 }
5603 0         0 elsif ($char[$i] eq '\L') {
5604             $char[$i] = '@{[Elatin5::lc qq<';
5605             $left_e++;
5606 0         0 }
5607 0         0 elsif ($char[$i] eq '\F') {
5608             $char[$i] = '@{[Elatin5::fc qq<';
5609             $left_e++;
5610 0         0 }
5611 0         0 elsif ($char[$i] eq '\Q') {
5612             $char[$i] = '@{[CORE::quotemeta qq<';
5613             $left_e++;
5614 0 0       0 }
5615 0         0 elsif ($char[$i] eq '\E') {
5616 0         0 if ($right_e < $left_e) {
5617             $char[$i] = '>]}';
5618             $right_e++;
5619 0         0 }
5620             else {
5621             $char[$i] = '';
5622             }
5623 0         0 }
5624 0 0       0 elsif ($char[$i] eq '\Q') {
5625 0         0 while (1) {
5626             if (++$i > $#char) {
5627 0 0       0 last;
5628 0         0 }
5629             if ($char[$i] eq '\E') {
5630             last;
5631             }
5632             }
5633             }
5634             elsif ($char[$i] eq '\E') {
5635             }
5636              
5637             # $0 --> $0
5638             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5639             }
5640             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5641             }
5642              
5643             # $$ --> $$
5644             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5645             }
5646              
5647             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5648 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5649             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5650             $char[$i] = e_capture($1);
5651 0         0 }
5652             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5653             $char[$i] = e_capture($1);
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_bracket)*? \] ) \z/oxms) {
5658             $char[$i] = e_capture($1.'->'.$2);
5659             }
5660              
5661 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5662             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5663             $char[$i] = e_capture($1.'->'.$2);
5664             }
5665              
5666 0         0 # $$foo
5667             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5668             $char[$i] = e_capture($1);
5669             }
5670              
5671 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
5672             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5673             $char[$i] = '@{[Elatin5::PREMATCH()]}';
5674             }
5675              
5676 8         44 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
5677             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5678             $char[$i] = '@{[Elatin5::MATCH()]}';
5679             }
5680              
5681 8         48 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
5682             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5683             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
5684             }
5685              
5686             # ${ foo } --> ${ foo }
5687             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5688             }
5689              
5690 6         35 # ${ ... }
5691             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5692             $char[$i] = e_capture($1);
5693             }
5694             }
5695 0 50       0  
5696 93         204 # return string
5697             if ($left_e > $right_e) {
5698 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5699             }
5700             return join '', @char;
5701             }
5702              
5703             #
5704             # escape regexp (m//, qr//)
5705 93     652 0 752 #
5706 652   100     2772 sub e_qr {
5707             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5708 652         2523 $modifier ||= '';
5709 652 50       1132  
5710 652         1503 $modifier =~ tr/p//d;
5711 0         0 if ($modifier =~ /([adlu])/oxms) {
5712 0 0       0 my $line = 0;
5713 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5714 0         0 if ($filename ne __FILE__) {
5715             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5716             last;
5717 0         0 }
5718             }
5719             die qq{Unsupported modifier "$1" used at line $line.\n};
5720 0         0 }
5721              
5722             $slash = 'div';
5723 652 100       1199  
    100          
5724 652         1891 # literal null string pattern
5725 8         10 if ($string eq '') {
5726 8         10 $modifier =~ tr/bB//d;
5727             $modifier =~ tr/i//d;
5728             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5729             }
5730              
5731             # /b /B modifier
5732             elsif ($modifier =~ tr/bB//d) {
5733 8 50       38  
5734 2         4 # choice again delimiter
5735 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5736 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5737 0         0 my %octet = map {$_ => 1} @char;
5738 0         0 if (not $octet{')'}) {
5739             $delimiter = '(';
5740             $end_delimiter = ')';
5741 0         0 }
5742 0         0 elsif (not $octet{'}'}) {
5743             $delimiter = '{';
5744             $end_delimiter = '}';
5745 0         0 }
5746 0         0 elsif (not $octet{']'}) {
5747             $delimiter = '[';
5748             $end_delimiter = ']';
5749 0         0 }
5750 0         0 elsif (not $octet{'>'}) {
5751             $delimiter = '<';
5752             $end_delimiter = '>';
5753 0         0 }
5754 0 0       0 else {
5755 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5756 0         0 if (not $octet{$char}) {
5757 0         0 $delimiter = $char;
5758             $end_delimiter = $char;
5759             last;
5760             }
5761             }
5762             }
5763 0 50 33     0 }
5764 2         10  
5765             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5766             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5767 0         0 }
5768             else {
5769             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5770             }
5771 2 100       12 }
5772 642         1630  
5773             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5774             my $metachar = qr/[\@\\|[\]{^]/oxms;
5775 642         2223  
5776             # split regexp
5777             my @char = $string =~ /\G((?>
5778             [^\\\$\@\[\(] |
5779             \\x (?>[0-9A-Fa-f]{1,2}) |
5780             \\ (?>[0-7]{2,3}) |
5781             \\c [\x40-\x5F] |
5782             \\x\{ (?>[0-9A-Fa-f]+) \} |
5783             \\o\{ (?>[0-7]+) \} |
5784             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5785             \\ $q_char |
5786             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5787             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5788             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5789             [\$\@] $qq_variable |
5790             \$ (?>\s* [0-9]+) |
5791             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5792             \$ \$ (?![\w\{]) |
5793             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5794             \[\^ |
5795             \[\: (?>[a-z]+) :\] |
5796             \[\:\^ (?>[a-z]+) :\] |
5797             \(\? |
5798             $q_char
5799             ))/oxmsg;
5800 642 50       99546  
5801 642         2917 # choice again delimiter
  0         0  
5802 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5803 0         0 my %octet = map {$_ => 1} @char;
5804 0         0 if (not $octet{')'}) {
5805             $delimiter = '(';
5806             $end_delimiter = ')';
5807 0         0 }
5808 0         0 elsif (not $octet{'}'}) {
5809             $delimiter = '{';
5810             $end_delimiter = '}';
5811 0         0 }
5812 0         0 elsif (not $octet{']'}) {
5813             $delimiter = '[';
5814             $end_delimiter = ']';
5815 0         0 }
5816 0         0 elsif (not $octet{'>'}) {
5817             $delimiter = '<';
5818             $end_delimiter = '>';
5819 0         0 }
5820 0 0       0 else {
5821 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5822 0         0 if (not $octet{$char}) {
5823 0         0 $delimiter = $char;
5824             $end_delimiter = $char;
5825             last;
5826             }
5827             }
5828             }
5829 0         0 }
5830 642         981  
5831 642         831 my $left_e = 0;
5832             my $right_e = 0;
5833             for (my $i=0; $i <= $#char; $i++) {
5834 642 50 66     1619  
    50 66        
    100          
    100          
    100          
    100          
5835 1872         10099 # "\L\u" --> "\u\L"
5836             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5837             @char[$i,$i+1] = @char[$i+1,$i];
5838             }
5839              
5840 0         0 # "\U\l" --> "\l\U"
5841             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5842             @char[$i,$i+1] = @char[$i+1,$i];
5843             }
5844              
5845 0         0 # octal escape sequence
5846             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5847             $char[$i] = Elatin5::octchr($1);
5848             }
5849              
5850 1         4 # hexadecimal escape sequence
5851             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5852             $char[$i] = Elatin5::hexchr($1);
5853             }
5854              
5855             # \b{...} --> b\{...}
5856             # \B{...} --> B\{...}
5857             # \N{CHARNAME} --> N\{CHARNAME}
5858             # \p{PROPERTY} --> p\{PROPERTY}
5859 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5860             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5861             $char[$i] = $1 . '\\' . $2;
5862             }
5863              
5864 6         20 # \p, \P, \X --> p, P, X
5865             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5866             $char[$i] = $1;
5867 4 100 100     10 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5868              
5869             if (0) {
5870             }
5871 1872         5390  
5872 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5873 6         71 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5874             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)) {
5875             $char[$i] .= join '', splice @char, $i+1, 3;
5876 0         0 }
5877             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)) {
5878             $char[$i] .= join '', splice @char, $i+1, 2;
5879 0         0 }
5880             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)) {
5881             $char[$i] .= join '', splice @char, $i+1, 1;
5882             }
5883             }
5884              
5885 0         0 # open character class [...]
5886             elsif ($char[$i] eq '[') {
5887             my $left = $i;
5888              
5889             # [] make die "Unmatched [] in regexp ...\n"
5890 328 100       460 # (and so on)
5891 328         825  
5892             if ($char[$i+1] eq ']') {
5893             $i++;
5894 3         6 }
5895 328 50       411  
5896 1379         1959 while (1) {
5897             if (++$i > $#char) {
5898 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5899 1379         2040 }
5900             if ($char[$i] eq ']') {
5901             my $right = $i;
5902 328 100       433  
5903 328         1696 # [...]
  30         118  
5904             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5905             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);
5906 90         156 }
5907             else {
5908             splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
5909 298         1085 }
5910 328         567  
5911             $i = $left;
5912             last;
5913             }
5914             }
5915             }
5916              
5917 328         824 # open character class [^...]
5918             elsif ($char[$i] eq '[^') {
5919             my $left = $i;
5920              
5921             # [^] make die "Unmatched [] in regexp ...\n"
5922 74 100       97 # (and so on)
5923 74         176  
5924             if ($char[$i+1] eq ']') {
5925             $i++;
5926 4         7 }
5927 74 50       88  
5928 272         392 while (1) {
5929             if (++$i > $#char) {
5930 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5931 272         404 }
5932             if ($char[$i] eq ']') {
5933             my $right = $i;
5934 74 100       85  
5935 74         353 # [^...]
  30         74  
5936             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5937             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);
5938 90         137 }
5939             else {
5940             splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5941 44         213 }
5942 74         262  
5943             $i = $left;
5944             last;
5945             }
5946             }
5947             }
5948              
5949 74         207 # rewrite character class or escape character
5950             elsif (my $char = character_class($char[$i],$modifier)) {
5951             $char[$i] = $char;
5952             }
5953              
5954 139 50       333 # /i modifier
5955 20         31 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
5956             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
5957             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
5958 20         34 }
5959             else {
5960             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
5961             }
5962             }
5963              
5964 0 50       0 # \u \l \U \L \F \Q \E
5965 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5966             if ($right_e < $left_e) {
5967             $char[$i] = '\\' . $char[$i];
5968             }
5969 0         0 }
5970 0         0 elsif ($char[$i] eq '\u') {
5971             $char[$i] = '@{[Elatin5::ucfirst qq<';
5972             $left_e++;
5973 0         0 }
5974 0         0 elsif ($char[$i] eq '\l') {
5975             $char[$i] = '@{[Elatin5::lcfirst qq<';
5976             $left_e++;
5977 0         0 }
5978 1         2 elsif ($char[$i] eq '\U') {
5979             $char[$i] = '@{[Elatin5::uc qq<';
5980             $left_e++;
5981 1         3 }
5982 1         2 elsif ($char[$i] eq '\L') {
5983             $char[$i] = '@{[Elatin5::lc qq<';
5984             $left_e++;
5985 1         3 }
5986 18         36 elsif ($char[$i] eq '\F') {
5987             $char[$i] = '@{[Elatin5::fc qq<';
5988             $left_e++;
5989 18         42 }
5990 1         3 elsif ($char[$i] eq '\Q') {
5991             $char[$i] = '@{[CORE::quotemeta qq<';
5992             $left_e++;
5993 1 50       3 }
5994 21         37 elsif ($char[$i] eq '\E') {
5995 21         31 if ($right_e < $left_e) {
5996             $char[$i] = '>]}';
5997             $right_e++;
5998 21         45 }
5999             else {
6000             $char[$i] = '';
6001             }
6002 0         0 }
6003 0 0       0 elsif ($char[$i] eq '\Q') {
6004 0         0 while (1) {
6005             if (++$i > $#char) {
6006 0 0       0 last;
6007 0         0 }
6008             if ($char[$i] eq '\E') {
6009             last;
6010             }
6011             }
6012             }
6013             elsif ($char[$i] eq '\E') {
6014             }
6015              
6016 0 0       0 # $0 --> $0
6017 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6018             if ($ignorecase) {
6019             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6020             }
6021 0 0       0 }
6022 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6023             if ($ignorecase) {
6024             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6025             }
6026             }
6027              
6028             # $$ --> $$
6029             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6030             }
6031              
6032             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6033 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6034 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6035 0         0 $char[$i] = e_capture($1);
6036             if ($ignorecase) {
6037             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6038             }
6039 0         0 }
6040 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6041 0         0 $char[$i] = e_capture($1);
6042             if ($ignorecase) {
6043             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6044             }
6045             }
6046              
6047 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6048 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) {
6049 0         0 $char[$i] = e_capture($1.'->'.$2);
6050             if ($ignorecase) {
6051             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6052             }
6053             }
6054              
6055 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6056 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) {
6057 0         0 $char[$i] = e_capture($1.'->'.$2);
6058             if ($ignorecase) {
6059             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6060             }
6061             }
6062              
6063 0         0 # $$foo
6064 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6065 0         0 $char[$i] = e_capture($1);
6066             if ($ignorecase) {
6067             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6068             }
6069             }
6070              
6071 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
6072 8         21 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6073             if ($ignorecase) {
6074             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
6075 0         0 }
6076             else {
6077             $char[$i] = '@{[Elatin5::PREMATCH()]}';
6078             }
6079             }
6080              
6081 8 50       26 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
6082 8         23 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6083             if ($ignorecase) {
6084             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
6085 0         0 }
6086             else {
6087             $char[$i] = '@{[Elatin5::MATCH()]}';
6088             }
6089             }
6090              
6091 8 50       23 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
6092 6         16 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6093             if ($ignorecase) {
6094             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
6095 0         0 }
6096             else {
6097             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
6098             }
6099             }
6100              
6101 6 0       18 # ${ foo }
6102 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) {
6103             if ($ignorecase) {
6104             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6105             }
6106             }
6107              
6108 0         0 # ${ ... }
6109 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6110 0         0 $char[$i] = e_capture($1);
6111             if ($ignorecase) {
6112             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6113             }
6114             }
6115              
6116 0         0 # $scalar or @array
6117 21 100       61 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6118 21         172 $char[$i] = e_string($char[$i]);
6119             if ($ignorecase) {
6120             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6121             }
6122             }
6123              
6124 11 100 33     39 # quote character before ? + * {
    50          
6125             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6126             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6127 138         1346 }
6128 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6129 0         0 my $char = $char[$i-1];
6130             if ($char[$i] eq '{') {
6131             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6132 0         0 }
6133             else {
6134             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6135             }
6136 0         0 }
6137             else {
6138             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6139             }
6140             }
6141             }
6142 127         499  
6143 642 50       1124 # make regexp string
6144 642 0 0     1321 $modifier =~ tr/i//d;
6145 0         0 if ($left_e > $right_e) {
6146             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6147             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6148 0         0 }
6149             else {
6150             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6151 0 50 33     0 }
6152 642         3237 }
6153             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6154             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6155 0         0 }
6156             else {
6157             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6158             }
6159             }
6160              
6161             #
6162             # double quote stuff
6163 642     180 0 21083 #
6164             sub qq_stuff {
6165             my($delimiter,$end_delimiter,$stuff) = @_;
6166 180 100       278  
6167 180         3879 # scalar variable or array variable
6168             if ($stuff =~ /\A [\$\@] /oxms) {
6169             return $stuff;
6170             }
6171 100         336  
  80         202  
6172 80         880 # quote by delimiter
6173 80 50       330 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6174 80 50       153 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6175 80 50       116 next if $char eq $delimiter;
6176 80         143 next if $char eq $end_delimiter;
6177             if (not $octet{$char}) {
6178             return join '', 'qq', $char, $stuff, $char;
6179 80         304 }
6180             }
6181             return join '', 'qq', '<', $stuff, '>';
6182             }
6183              
6184             #
6185             # escape regexp (m'', qr'', and m''b, qr''b)
6186 0     10 0 0 #
6187 10   50     40 sub e_qr_q {
6188             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6189 10         43 $modifier ||= '';
6190 10 50       15  
6191 10         23 $modifier =~ tr/p//d;
6192 0         0 if ($modifier =~ /([adlu])/oxms) {
6193 0 0       0 my $line = 0;
6194 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6195 0         0 if ($filename ne __FILE__) {
6196             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6197             last;
6198 0         0 }
6199             }
6200             die qq{Unsupported modifier "$1" used at line $line.\n};
6201 0         0 }
6202              
6203             $slash = 'div';
6204 10 100       17  
    50          
6205 10         24 # literal null string pattern
6206 8         9 if ($string eq '') {
6207 8         10 $modifier =~ tr/bB//d;
6208             $modifier =~ tr/i//d;
6209             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6210             }
6211              
6212 8         37 # with /b /B modifier
6213             elsif ($modifier =~ tr/bB//d) {
6214             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6215             }
6216              
6217 0         0 # without /b /B modifier
6218             else {
6219             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6220             }
6221             }
6222              
6223             #
6224             # escape regexp (m'', qr'')
6225 2     2 0 9 #
6226             sub e_qr_qt {
6227 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6228              
6229             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6230 2         5  
6231             # split regexp
6232             my @char = $string =~ /\G((?>
6233             [^\\\[\$\@\/] |
6234             [\x00-\xFF] |
6235             \[\^ |
6236             \[\: (?>[a-z]+) \:\] |
6237             \[\:\^ (?>[a-z]+) \:\] |
6238             [\$\@\/] |
6239             \\ (?:$q_char) |
6240             (?:$q_char)
6241             ))/oxmsg;
6242 2         64  
6243 2 50 33     11 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6244             for (my $i=0; $i <= $#char; $i++) {
6245             if (0) {
6246             }
6247 2         16  
6248 0         0 # open character class [...]
6249 0 0       0 elsif ($char[$i] eq '[') {
6250 0         0 my $left = $i;
6251             if ($char[$i+1] eq ']') {
6252 0         0 $i++;
6253 0 0       0 }
6254 0         0 while (1) {
6255             if (++$i > $#char) {
6256 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6257 0         0 }
6258             if ($char[$i] eq ']') {
6259             my $right = $i;
6260 0         0  
6261             # [...]
6262 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6263 0         0  
6264             $i = $left;
6265             last;
6266             }
6267             }
6268             }
6269              
6270 0         0 # open character class [^...]
6271 0 0       0 elsif ($char[$i] eq '[^') {
6272 0         0 my $left = $i;
6273             if ($char[$i+1] eq ']') {
6274 0         0 $i++;
6275 0 0       0 }
6276 0         0 while (1) {
6277             if (++$i > $#char) {
6278 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6279 0         0 }
6280             if ($char[$i] eq ']') {
6281             my $right = $i;
6282 0         0  
6283             # [^...]
6284 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6285 0         0  
6286             $i = $left;
6287             last;
6288             }
6289             }
6290             }
6291              
6292 0         0 # escape $ @ / and \
6293             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6294             $char[$i] = '\\' . $char[$i];
6295             }
6296              
6297 0         0 # rewrite character class or escape character
6298             elsif (my $char = character_class($char[$i],$modifier)) {
6299             $char[$i] = $char;
6300             }
6301              
6302 0 0       0 # /i modifier
6303 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6304             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6305             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6306 0         0 }
6307             else {
6308             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6309             }
6310             }
6311              
6312 0 0       0 # quote character before ? + * {
6313             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6314             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6315 0         0 }
6316             else {
6317             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6318             }
6319             }
6320 0         0 }
6321 2         8  
6322             $delimiter = '/';
6323 2         3 $end_delimiter = '/';
6324 2         4  
6325             $modifier =~ tr/i//d;
6326             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6327             }
6328              
6329             #
6330             # escape regexp (m''b, qr''b)
6331 2     0 0 18 #
6332             sub e_qr_qb {
6333             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6334 0         0  
6335             # split regexp
6336             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6337 0         0  
6338 0 0       0 # unescape character
    0          
6339             for (my $i=0; $i <= $#char; $i++) {
6340             if (0) {
6341             }
6342 0         0  
6343             # remain \\
6344             elsif ($char[$i] eq '\\\\') {
6345             }
6346              
6347 0         0 # escape $ @ / and \
6348             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6349             $char[$i] = '\\' . $char[$i];
6350             }
6351 0         0 }
6352 0         0  
6353 0         0 $delimiter = '/';
6354             $end_delimiter = '/';
6355             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6356             }
6357              
6358             #
6359             # escape regexp (s/here//)
6360 0     76 0 0 #
6361 76   100     230 sub e_s1 {
6362             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6363 76         340 $modifier ||= '';
6364 76 50       121  
6365 76         312 $modifier =~ tr/p//d;
6366 0         0 if ($modifier =~ /([adlu])/oxms) {
6367 0 0       0 my $line = 0;
6368 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6369 0         0 if ($filename ne __FILE__) {
6370             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6371             last;
6372 0         0 }
6373             }
6374             die qq{Unsupported modifier "$1" used at line $line.\n};
6375 0         0 }
6376              
6377             $slash = 'div';
6378 76 100       192  
    50          
6379 76         306 # literal null string pattern
6380 8         11 if ($string eq '') {
6381 8         9 $modifier =~ tr/bB//d;
6382             $modifier =~ tr/i//d;
6383             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6384             }
6385              
6386             # /b /B modifier
6387             elsif ($modifier =~ tr/bB//d) {
6388 8 0       53  
6389 0         0 # choice again delimiter
6390 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6391 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6392 0         0 my %octet = map {$_ => 1} @char;
6393 0         0 if (not $octet{')'}) {
6394             $delimiter = '(';
6395             $end_delimiter = ')';
6396 0         0 }
6397 0         0 elsif (not $octet{'}'}) {
6398             $delimiter = '{';
6399             $end_delimiter = '}';
6400 0         0 }
6401 0         0 elsif (not $octet{']'}) {
6402             $delimiter = '[';
6403             $end_delimiter = ']';
6404 0         0 }
6405 0         0 elsif (not $octet{'>'}) {
6406             $delimiter = '<';
6407             $end_delimiter = '>';
6408 0         0 }
6409 0 0       0 else {
6410 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6411 0         0 if (not $octet{$char}) {
6412 0         0 $delimiter = $char;
6413             $end_delimiter = $char;
6414             last;
6415             }
6416             }
6417             }
6418 0         0 }
6419 0         0  
6420             my $prematch = '';
6421             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6422 0 100       0 }
6423 68         213  
6424             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6425             my $metachar = qr/[\@\\|[\]{^]/oxms;
6426 68         359  
6427             # split regexp
6428             my @char = $string =~ /\G((?>
6429             [^\\\$\@\[\(] |
6430             \\ (?>[1-9][0-9]*) |
6431             \\g (?>\s*) (?>[1-9][0-9]*) |
6432             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6433             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6434             \\x (?>[0-9A-Fa-f]{1,2}) |
6435             \\ (?>[0-7]{2,3}) |
6436             \\c [\x40-\x5F] |
6437             \\x\{ (?>[0-9A-Fa-f]+) \} |
6438             \\o\{ (?>[0-7]+) \} |
6439             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6440             \\ $q_char |
6441             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6442             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6443             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6444             [\$\@] $qq_variable |
6445             \$ (?>\s* [0-9]+) |
6446             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6447             \$ \$ (?![\w\{]) |
6448             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6449             \[\^ |
6450             \[\: (?>[a-z]+) :\] |
6451             \[\:\^ (?>[a-z]+) :\] |
6452             \(\? |
6453             $q_char
6454             ))/oxmsg;
6455 68 50       16621  
6456 68         487 # choice again delimiter
  0         0  
6457 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6458 0         0 my %octet = map {$_ => 1} @char;
6459 0         0 if (not $octet{')'}) {
6460             $delimiter = '(';
6461             $end_delimiter = ')';
6462 0         0 }
6463 0         0 elsif (not $octet{'}'}) {
6464             $delimiter = '{';
6465             $end_delimiter = '}';
6466 0         0 }
6467 0         0 elsif (not $octet{']'}) {
6468             $delimiter = '[';
6469             $end_delimiter = ']';
6470 0         0 }
6471 0         0 elsif (not $octet{'>'}) {
6472             $delimiter = '<';
6473             $end_delimiter = '>';
6474 0         0 }
6475 0 0       0 else {
6476 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6477 0         0 if (not $octet{$char}) {
6478 0         0 $delimiter = $char;
6479             $end_delimiter = $char;
6480             last;
6481             }
6482             }
6483             }
6484             }
6485 0         0  
  68         424  
6486             # count '('
6487 253         461 my $parens = grep { $_ eq '(' } @char;
6488 68         115  
6489 68         103 my $left_e = 0;
6490             my $right_e = 0;
6491             for (my $i=0; $i <= $#char; $i++) {
6492 68 50 33     221  
    50 33        
    100          
    100          
    50          
    50          
6493 195         1607 # "\L\u" --> "\u\L"
6494             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6495             @char[$i,$i+1] = @char[$i+1,$i];
6496             }
6497              
6498 0         0 # "\U\l" --> "\l\U"
6499             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6500             @char[$i,$i+1] = @char[$i+1,$i];
6501             }
6502              
6503 0         0 # octal escape sequence
6504             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6505             $char[$i] = Elatin5::octchr($1);
6506             }
6507              
6508 1         4 # hexadecimal escape sequence
6509             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6510             $char[$i] = Elatin5::hexchr($1);
6511             }
6512              
6513             # \b{...} --> b\{...}
6514             # \B{...} --> B\{...}
6515             # \N{CHARNAME} --> N\{CHARNAME}
6516             # \p{PROPERTY} --> p\{PROPERTY}
6517 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6518             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6519             $char[$i] = $1 . '\\' . $2;
6520             }
6521              
6522 0         0 # \p, \P, \X --> p, P, X
6523             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6524             $char[$i] = $1;
6525 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          
6526              
6527             if (0) {
6528             }
6529 195         843  
6530 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6531 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6532             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)) {
6533             $char[$i] .= join '', splice @char, $i+1, 3;
6534 0         0 }
6535             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)) {
6536             $char[$i] .= join '', splice @char, $i+1, 2;
6537 0         0 }
6538             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)) {
6539             $char[$i] .= join '', splice @char, $i+1, 1;
6540             }
6541             }
6542              
6543 0         0 # open character class [...]
6544 13 50       21 elsif ($char[$i] eq '[') {
6545 13         39 my $left = $i;
6546             if ($char[$i+1] eq ']') {
6547 0         0 $i++;
6548 13 50       17 }
6549 58         88 while (1) {
6550             if (++$i > $#char) {
6551 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6552 58         133 }
6553             if ($char[$i] eq ']') {
6554             my $right = $i;
6555 13 50       22  
6556 13         75 # [...]
  0         0  
6557             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6558             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);
6559 0         0 }
6560             else {
6561             splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6562 13         53 }
6563 13         26  
6564             $i = $left;
6565             last;
6566             }
6567             }
6568             }
6569              
6570 13         57 # open character class [^...]
6571 0 0       0 elsif ($char[$i] eq '[^') {
6572 0         0 my $left = $i;
6573             if ($char[$i+1] eq ']') {
6574 0         0 $i++;
6575 0 0       0 }
6576 0         0 while (1) {
6577             if (++$i > $#char) {
6578 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6579 0         0 }
6580             if ($char[$i] eq ']') {
6581             my $right = $i;
6582 0 0       0  
6583 0         0 # [^...]
  0         0  
6584             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6585             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);
6586 0         0 }
6587             else {
6588             splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6589 0         0 }
6590 0         0  
6591             $i = $left;
6592             last;
6593             }
6594             }
6595             }
6596              
6597 0         0 # rewrite character class or escape character
6598             elsif (my $char = character_class($char[$i],$modifier)) {
6599             $char[$i] = $char;
6600             }
6601              
6602 7 50       15 # /i modifier
6603 3         5 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6604             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6605             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6606 3         6 }
6607             else {
6608             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6609             }
6610             }
6611              
6612 0 0       0 # \u \l \U \L \F \Q \E
6613 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6614             if ($right_e < $left_e) {
6615             $char[$i] = '\\' . $char[$i];
6616             }
6617 0         0 }
6618 0         0 elsif ($char[$i] eq '\u') {
6619             $char[$i] = '@{[Elatin5::ucfirst qq<';
6620             $left_e++;
6621 0         0 }
6622 0         0 elsif ($char[$i] eq '\l') {
6623             $char[$i] = '@{[Elatin5::lcfirst qq<';
6624             $left_e++;
6625 0         0 }
6626 0         0 elsif ($char[$i] eq '\U') {
6627             $char[$i] = '@{[Elatin5::uc qq<';
6628             $left_e++;
6629 0         0 }
6630 0         0 elsif ($char[$i] eq '\L') {
6631             $char[$i] = '@{[Elatin5::lc qq<';
6632             $left_e++;
6633 0         0 }
6634 0         0 elsif ($char[$i] eq '\F') {
6635             $char[$i] = '@{[Elatin5::fc qq<';
6636             $left_e++;
6637 0         0 }
6638 0         0 elsif ($char[$i] eq '\Q') {
6639             $char[$i] = '@{[CORE::quotemeta qq<';
6640             $left_e++;
6641 0 0       0 }
6642 0         0 elsif ($char[$i] eq '\E') {
6643 0         0 if ($right_e < $left_e) {
6644             $char[$i] = '>]}';
6645             $right_e++;
6646 0         0 }
6647             else {
6648             $char[$i] = '';
6649             }
6650 0         0 }
6651 0 0       0 elsif ($char[$i] eq '\Q') {
6652 0         0 while (1) {
6653             if (++$i > $#char) {
6654 0 0       0 last;
6655 0         0 }
6656             if ($char[$i] eq '\E') {
6657             last;
6658             }
6659             }
6660             }
6661             elsif ($char[$i] eq '\E') {
6662             }
6663              
6664             # \0 --> \0
6665             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6666             }
6667              
6668             # \g{N}, \g{-N}
6669              
6670             # P.108 Using Simple Patterns
6671             # in Chapter 7: In the World of Regular Expressions
6672             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6673              
6674             # P.221 Capturing
6675             # in Chapter 5: Pattern Matching
6676             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6677              
6678             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6679             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6680             }
6681              
6682             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6683             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6684             }
6685              
6686             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6687             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6688             }
6689              
6690             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6691             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6692             }
6693              
6694 0 0       0 # $0 --> $0
6695 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6696             if ($ignorecase) {
6697             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6698             }
6699 0 0       0 }
6700 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6701             if ($ignorecase) {
6702             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6703             }
6704             }
6705              
6706             # $$ --> $$
6707             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6708             }
6709              
6710             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6711 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6712 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6713 0         0 $char[$i] = e_capture($1);
6714             if ($ignorecase) {
6715             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6716             }
6717 0         0 }
6718 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6719 0         0 $char[$i] = e_capture($1);
6720             if ($ignorecase) {
6721             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6722             }
6723             }
6724              
6725 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6726 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) {
6727 0         0 $char[$i] = e_capture($1.'->'.$2);
6728             if ($ignorecase) {
6729             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6730             }
6731             }
6732              
6733 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6734 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) {
6735 0         0 $char[$i] = e_capture($1.'->'.$2);
6736             if ($ignorecase) {
6737             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6738             }
6739             }
6740              
6741 0         0 # $$foo
6742 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6743 0         0 $char[$i] = e_capture($1);
6744             if ($ignorecase) {
6745             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6746             }
6747             }
6748              
6749 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
6750 4         13 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6751             if ($ignorecase) {
6752             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
6753 0         0 }
6754             else {
6755             $char[$i] = '@{[Elatin5::PREMATCH()]}';
6756             }
6757             }
6758              
6759 4 50       17 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
6760 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6761             if ($ignorecase) {
6762             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
6763 0         0 }
6764             else {
6765             $char[$i] = '@{[Elatin5::MATCH()]}';
6766             }
6767             }
6768              
6769 4 50       16 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
6770 3         11 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6771             if ($ignorecase) {
6772             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
6773 0         0 }
6774             else {
6775             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
6776             }
6777             }
6778              
6779 3 0       13 # ${ foo }
6780 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) {
6781             if ($ignorecase) {
6782             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6783             }
6784             }
6785              
6786 0         0 # ${ ... }
6787 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6788 0         0 $char[$i] = e_capture($1);
6789             if ($ignorecase) {
6790             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6791             }
6792             }
6793              
6794 0         0 # $scalar or @array
6795 4 50       24 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6796 4         23 $char[$i] = e_string($char[$i]);
6797             if ($ignorecase) {
6798             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6799             }
6800             }
6801              
6802 0 50       0 # quote character before ? + * {
6803             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6804             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6805 13         62 }
6806             else {
6807             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6808             }
6809             }
6810             }
6811 13         61  
6812 68         164 # make regexp string
6813 68 50       122 my $prematch = '';
6814 68         171 $modifier =~ tr/i//d;
6815             if ($left_e > $right_e) {
6816 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6817             }
6818             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6819             }
6820              
6821             #
6822             # escape regexp (s'here'' or s'here''b)
6823 68     21 0 1600 #
6824 21   100     130 sub e_s1_q {
6825             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6826 21         139 $modifier ||= '';
6827 21 50       33  
6828 21         52 $modifier =~ tr/p//d;
6829 0         0 if ($modifier =~ /([adlu])/oxms) {
6830 0 0       0 my $line = 0;
6831 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6832 0         0 if ($filename ne __FILE__) {
6833             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6834             last;
6835 0         0 }
6836             }
6837             die qq{Unsupported modifier "$1" used at line $line.\n};
6838 0         0 }
6839              
6840             $slash = 'div';
6841 21 100       35  
    50          
6842 21         61 # literal null string pattern
6843 8         8 if ($string eq '') {
6844 8         9 $modifier =~ tr/bB//d;
6845             $modifier =~ tr/i//d;
6846             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6847             }
6848              
6849 8         44 # with /b /B modifier
6850             elsif ($modifier =~ tr/bB//d) {
6851             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6852             }
6853              
6854 0         0 # without /b /B modifier
6855             else {
6856             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6857             }
6858             }
6859              
6860             #
6861             # escape regexp (s'here'')
6862 13     13 0 64 #
6863             sub e_s1_qt {
6864 13 50       87 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6865              
6866             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6867 13         36  
6868             # split regexp
6869             my @char = $string =~ /\G((?>
6870             [^\\\[\$\@\/] |
6871             [\x00-\xFF] |
6872             \[\^ |
6873             \[\: (?>[a-z]+) \:\] |
6874             \[\:\^ (?>[a-z]+) \:\] |
6875             [\$\@\/] |
6876             \\ (?:$q_char) |
6877             (?:$q_char)
6878             ))/oxmsg;
6879 13         240  
6880 13 50 33     47 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6881             for (my $i=0; $i <= $#char; $i++) {
6882             if (0) {
6883             }
6884 25         107  
6885 0         0 # open character class [...]
6886 0 0       0 elsif ($char[$i] eq '[') {
6887 0         0 my $left = $i;
6888             if ($char[$i+1] eq ']') {
6889 0         0 $i++;
6890 0 0       0 }
6891 0         0 while (1) {
6892             if (++$i > $#char) {
6893 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6894 0         0 }
6895             if ($char[$i] eq ']') {
6896             my $right = $i;
6897 0         0  
6898             # [...]
6899 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6900 0         0  
6901             $i = $left;
6902             last;
6903             }
6904             }
6905             }
6906              
6907 0         0 # open character class [^...]
6908 0 0       0 elsif ($char[$i] eq '[^') {
6909 0         0 my $left = $i;
6910             if ($char[$i+1] eq ']') {
6911 0         0 $i++;
6912 0 0       0 }
6913 0         0 while (1) {
6914             if (++$i > $#char) {
6915 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6916 0         0 }
6917             if ($char[$i] eq ']') {
6918             my $right = $i;
6919 0         0  
6920             # [^...]
6921 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6922 0         0  
6923             $i = $left;
6924             last;
6925             }
6926             }
6927             }
6928              
6929 0         0 # escape $ @ / and \
6930             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6931             $char[$i] = '\\' . $char[$i];
6932             }
6933              
6934 0         0 # rewrite character class or escape character
6935             elsif (my $char = character_class($char[$i],$modifier)) {
6936             $char[$i] = $char;
6937             }
6938              
6939 6 0       16 # /i modifier
6940 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6941             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6942             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6943 0         0 }
6944             else {
6945             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6946             }
6947             }
6948              
6949 0 0       0 # quote character before ? + * {
6950             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6951             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6952 0         0 }
6953             else {
6954             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6955             }
6956             }
6957 0         0 }
6958 13         27  
6959 13         27 $modifier =~ tr/i//d;
6960 13         20 $delimiter = '/';
6961 13         16 $end_delimiter = '/';
6962             my $prematch = '';
6963             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6964             }
6965              
6966             #
6967             # escape regexp (s'here''b)
6968 13     0 0 246 #
6969             sub e_s1_qb {
6970             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6971 0         0  
6972             # split regexp
6973             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6974 0         0  
6975 0 0       0 # unescape character
    0          
6976             for (my $i=0; $i <= $#char; $i++) {
6977             if (0) {
6978             }
6979 0         0  
6980             # remain \\
6981             elsif ($char[$i] eq '\\\\') {
6982             }
6983              
6984 0         0 # escape $ @ / and \
6985             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6986             $char[$i] = '\\' . $char[$i];
6987             }
6988 0         0 }
6989 0         0  
6990 0         0 $delimiter = '/';
6991 0         0 $end_delimiter = '/';
6992             my $prematch = '';
6993             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6994             }
6995              
6996             #
6997             # escape regexp (s''here')
6998 0     16 0 0 #
6999             sub e_s2_q {
7000 16         39 my($ope,$delimiter,$end_delimiter,$string) = @_;
7001              
7002 16         23 $slash = 'div';
7003 16         177  
7004 16 100       49 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7005             for (my $i=0; $i <= $#char; $i++) {
7006             if (0) {
7007             }
7008 9         35  
7009             # not escape \\
7010             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7011             }
7012              
7013 0         0 # escape $ @ / and \
7014             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7015             $char[$i] = '\\' . $char[$i];
7016             }
7017 5         16 }
7018              
7019             return join '', $ope, $delimiter, @char, $end_delimiter;
7020             }
7021              
7022             #
7023             # escape regexp (s/here/and here/modifier)
7024 16     97 0 58 #
7025 97   100     896 sub e_sub {
7026             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7027 97         761 $modifier ||= '';
7028 97 50       275  
7029 97         272 $modifier =~ tr/p//d;
7030 0         0 if ($modifier =~ /([adlu])/oxms) {
7031 0 0       0 my $line = 0;
7032 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7033 0         0 if ($filename ne __FILE__) {
7034             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7035             last;
7036 0         0 }
7037             }
7038             die qq{Unsupported modifier "$1" used at line $line.\n};
7039 0 100       0 }
7040 97         256  
7041 36         49 if ($variable eq '') {
7042             $variable = '$_';
7043             $bind_operator = ' =~ ';
7044 36         57 }
7045              
7046             $slash = 'div';
7047              
7048             # P.128 Start of match (or end of previous match): \G
7049             # P.130 Advanced Use of \G with Perl
7050             # in Chapter 3: Overview of Regular Expression Features and Flavors
7051             # P.312 Iterative Matching: Scalar Context, with /g
7052             # in Chapter 7: Perl
7053             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7054              
7055             # P.181 Where You Left Off: The \G Assertion
7056             # in Chapter 5: Pattern Matching
7057             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7058              
7059             # P.220 Where You Left Off: The \G Assertion
7060             # in Chapter 5: Pattern Matching
7061 97         312 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7062 97         310  
7063             my $e_modifier = $modifier =~ tr/e//d;
7064 97         351 my $r_modifier = $modifier =~ tr/r//d;
7065 97 50       324  
7066 97         740 my $my = '';
7067 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7068 0         0 $my = $variable;
7069             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7070             $variable =~ s/ = .+ \z//oxms;
7071 0         0 }
7072 97         407  
7073             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7074             $variable_basename =~ s/ \s+ \z//oxms;
7075 97         188  
7076 97 100       477 # quote replacement string
7077 97         232 my $e_replacement = '';
7078 17         41 if ($e_modifier >= 1) {
7079             $e_replacement = e_qq('', '', '', $replacement);
7080             $e_modifier--;
7081 17 100       78 }
7082 80         372 else {
7083             if ($delimiter2 eq "'") {
7084             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7085 16         39 }
7086             else {
7087             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7088             }
7089 64         167 }
7090              
7091             my $sub = '';
7092 97 100       158  
7093 97 100       249 # with /r
7094             if ($r_modifier) {
7095             if (0) {
7096             }
7097 8         18  
7098 0 50       0 # s///gr without multibyte anchoring
7099             elsif ($modifier =~ /g/oxms) {
7100             $sub = sprintf(
7101             # 1 2 3 4 5
7102             q,
7103              
7104             $variable, # 1
7105             ($delimiter1 eq "'") ? # 2
7106             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7107             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7108             $s_matched, # 3
7109             $e_replacement, # 4
7110             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 5
7111             );
7112             }
7113              
7114             # s///r
7115 4         12 else {
7116              
7117 4 50       5 my $prematch = q{$`};
7118              
7119             $sub = sprintf(
7120             # 1 2 3 4 5 6 7
7121             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin5::re_r=%s; %s"%s$Elatin5::re_r$'" } : %s>,
7122              
7123             $variable, # 1
7124             ($delimiter1 eq "'") ? # 2
7125             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7126             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7127             $s_matched, # 3
7128             $e_replacement, # 4
7129             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 5
7130             $prematch, # 6
7131             $variable, # 7
7132             );
7133             }
7134 4 50       11  
7135 8         25 # $var !~ s///r doesn't make sense
7136             if ($bind_operator =~ / !~ /oxms) {
7137             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7138             }
7139             }
7140              
7141 0 100       0 # without /r
7142             else {
7143             if (0) {
7144             }
7145 89         234  
7146 0 100       0 # s///g without multibyte anchoring
    100          
7147             elsif ($modifier =~ /g/oxms) {
7148             $sub = sprintf(
7149             # 1 2 3 4 5 6 7 8
7150             q,
7151              
7152             $variable, # 1
7153             ($delimiter1 eq "'") ? # 2
7154             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7155             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7156             $s_matched, # 3
7157             $e_replacement, # 4
7158             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 5
7159             $variable, # 6
7160             $variable, # 7
7161             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7162             );
7163             }
7164              
7165             # s///
7166 22         98 else {
7167              
7168 67 100       110 my $prematch = q{$`};
    100          
7169              
7170             $sub = sprintf(
7171              
7172             ($bind_operator =~ / =~ /oxms) ?
7173              
7174             # 1 2 3 4 5 6 7 8
7175             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin5::re_r=%s; %s%s="%s$Elatin5::re_r$'"; 1 } : undef> :
7176              
7177             # 1 2 3 4 5 6 7 8
7178             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin5::re_r=%s; %s%s="%s$Elatin5::re_r$'"; undef }>,
7179              
7180             $variable, # 1
7181             $bind_operator, # 2
7182             ($delimiter1 eq "'") ? # 3
7183             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7184             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7185             $s_matched, # 4
7186             $e_replacement, # 5
7187             '$Elatin5::re_r=CORE::eval $Elatin5::re_r; ' x $e_modifier, # 6
7188             $variable, # 7
7189             $prematch, # 8
7190             );
7191             }
7192             }
7193 67 50       423  
7194 97         334 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7195             if ($my ne '') {
7196             $sub = "($my, $sub)[1]";
7197             }
7198 0         0  
7199 97         163 # clear s/// variable
7200             $sub_variable = '';
7201 97         124 $bind_operator = '';
7202              
7203             return $sub;
7204             }
7205              
7206             #
7207             # escape regexp of split qr//
7208 97     74 0 747 #
7209 74   100     336 sub e_split {
7210             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7211 74         361 $modifier ||= '';
7212 74 50       136  
7213 74         165 $modifier =~ tr/p//d;
7214 0         0 if ($modifier =~ /([adlu])/oxms) {
7215 0 0       0 my $line = 0;
7216 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7217 0         0 if ($filename ne __FILE__) {
7218             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7219             last;
7220 0         0 }
7221             }
7222             die qq{Unsupported modifier "$1" used at line $line.\n};
7223 0         0 }
7224              
7225             $slash = 'div';
7226 74 50       142  
7227 74         168 # /b /B modifier
7228             if ($modifier =~ tr/bB//d) {
7229             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7230 0 50       0 }
7231 74         176  
7232             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7233             my $metachar = qr/[\@\\|[\]{^]/oxms;
7234 74         260  
7235             # split regexp
7236             my @char = $string =~ /\G((?>
7237             [^\\\$\@\[\(] |
7238             \\x (?>[0-9A-Fa-f]{1,2}) |
7239             \\ (?>[0-7]{2,3}) |
7240             \\c [\x40-\x5F] |
7241             \\x\{ (?>[0-9A-Fa-f]+) \} |
7242             \\o\{ (?>[0-7]+) \} |
7243             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7244             \\ $q_char |
7245             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7246             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7247             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7248             [\$\@] $qq_variable |
7249             \$ (?>\s* [0-9]+) |
7250             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7251             \$ \$ (?![\w\{]) |
7252             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7253             \[\^ |
7254             \[\: (?>[a-z]+) :\] |
7255             \[\:\^ (?>[a-z]+) :\] |
7256             \(\? |
7257             $q_char
7258 74         8984 ))/oxmsg;
7259 74         564  
7260 74         138 my $left_e = 0;
7261             my $right_e = 0;
7262             for (my $i=0; $i <= $#char; $i++) {
7263 74 50 33     348  
    50 33        
    100          
    100          
    50          
    50          
7264 249         1256 # "\L\u" --> "\u\L"
7265             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7266             @char[$i,$i+1] = @char[$i+1,$i];
7267             }
7268              
7269 0         0 # "\U\l" --> "\l\U"
7270             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7271             @char[$i,$i+1] = @char[$i+1,$i];
7272             }
7273              
7274 0         0 # octal escape sequence
7275             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7276             $char[$i] = Elatin5::octchr($1);
7277             }
7278              
7279 1         4 # hexadecimal escape sequence
7280             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7281             $char[$i] = Elatin5::hexchr($1);
7282             }
7283              
7284             # \b{...} --> b\{...}
7285             # \B{...} --> B\{...}
7286             # \N{CHARNAME} --> N\{CHARNAME}
7287             # \p{PROPERTY} --> p\{PROPERTY}
7288 1         4 # \P{PROPERTY} --> P\{PROPERTY}
7289             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7290             $char[$i] = $1 . '\\' . $2;
7291             }
7292              
7293 0         0 # \p, \P, \X --> p, P, X
7294             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7295             $char[$i] = $1;
7296 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          
7297              
7298             if (0) {
7299             }
7300 249         796  
7301 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7302 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7303             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)) {
7304             $char[$i] .= join '', splice @char, $i+1, 3;
7305 0         0 }
7306             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)) {
7307             $char[$i] .= join '', splice @char, $i+1, 2;
7308 0         0 }
7309             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)) {
7310             $char[$i] .= join '', splice @char, $i+1, 1;
7311             }
7312             }
7313              
7314 0         0 # open character class [...]
7315 3 50       5 elsif ($char[$i] eq '[') {
7316 3         10 my $left = $i;
7317             if ($char[$i+1] eq ']') {
7318 0         0 $i++;
7319 3 50       4 }
7320 7         12 while (1) {
7321             if (++$i > $#char) {
7322 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7323 7         18 }
7324             if ($char[$i] eq ']') {
7325             my $right = $i;
7326 3 50       5  
7327 3         20 # [...]
  0         0  
7328             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7329             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);
7330 0         0 }
7331             else {
7332             splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
7333 3         19 }
7334 3         4  
7335             $i = $left;
7336             last;
7337             }
7338             }
7339             }
7340              
7341 3         7 # open character class [^...]
7342 0 0       0 elsif ($char[$i] eq '[^') {
7343 0         0 my $left = $i;
7344             if ($char[$i+1] eq ']') {
7345 0         0 $i++;
7346 0 0       0 }
7347 0         0 while (1) {
7348             if (++$i > $#char) {
7349 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7350 0         0 }
7351             if ($char[$i] eq ']') {
7352             my $right = $i;
7353 0 0       0  
7354 0         0 # [^...]
  0         0  
7355             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7356             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);
7357 0         0 }
7358             else {
7359             splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7360 0         0 }
7361 0         0  
7362             $i = $left;
7363             last;
7364             }
7365             }
7366             }
7367              
7368 0         0 # rewrite character class or escape character
7369             elsif (my $char = character_class($char[$i],$modifier)) {
7370             $char[$i] = $char;
7371             }
7372              
7373             # P.794 29.2.161. split
7374             # in Chapter 29: Functions
7375             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7376              
7377             # P.951 split
7378             # in Chapter 27: Functions
7379             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7380              
7381             # said "The //m modifier is assumed when you split on the pattern /^/",
7382             # but perl5.008 is not so. Therefore, this software adds //m.
7383             # (and so on)
7384              
7385 1         3 # split(m/^/) --> split(m/^/m)
7386             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7387             $modifier .= 'm';
7388             }
7389              
7390 7 0       21 # /i modifier
7391 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
7392             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
7393             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
7394 0         0 }
7395             else {
7396             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
7397             }
7398             }
7399              
7400 0 0       0 # \u \l \U \L \F \Q \E
7401 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7402             if ($right_e < $left_e) {
7403             $char[$i] = '\\' . $char[$i];
7404             }
7405 0         0 }
7406 0         0 elsif ($char[$i] eq '\u') {
7407             $char[$i] = '@{[Elatin5::ucfirst qq<';
7408             $left_e++;
7409 0         0 }
7410 0         0 elsif ($char[$i] eq '\l') {
7411             $char[$i] = '@{[Elatin5::lcfirst qq<';
7412             $left_e++;
7413 0         0 }
7414 0         0 elsif ($char[$i] eq '\U') {
7415             $char[$i] = '@{[Elatin5::uc qq<';
7416             $left_e++;
7417 0         0 }
7418 0         0 elsif ($char[$i] eq '\L') {
7419             $char[$i] = '@{[Elatin5::lc qq<';
7420             $left_e++;
7421 0         0 }
7422 0         0 elsif ($char[$i] eq '\F') {
7423             $char[$i] = '@{[Elatin5::fc qq<';
7424             $left_e++;
7425 0         0 }
7426 0         0 elsif ($char[$i] eq '\Q') {
7427             $char[$i] = '@{[CORE::quotemeta qq<';
7428             $left_e++;
7429 0 0       0 }
7430 0         0 elsif ($char[$i] eq '\E') {
7431 0         0 if ($right_e < $left_e) {
7432             $char[$i] = '>]}';
7433             $right_e++;
7434 0         0 }
7435             else {
7436             $char[$i] = '';
7437             }
7438 0         0 }
7439 0 0       0 elsif ($char[$i] eq '\Q') {
7440 0         0 while (1) {
7441             if (++$i > $#char) {
7442 0 0       0 last;
7443 0         0 }
7444             if ($char[$i] eq '\E') {
7445             last;
7446             }
7447             }
7448             }
7449             elsif ($char[$i] eq '\E') {
7450             }
7451              
7452 0 0       0 # $0 --> $0
7453 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7454             if ($ignorecase) {
7455             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7456             }
7457 0 0       0 }
7458 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7459             if ($ignorecase) {
7460             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7461             }
7462             }
7463              
7464             # $$ --> $$
7465             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7466             }
7467              
7468             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7469 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7470 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7471 0         0 $char[$i] = e_capture($1);
7472             if ($ignorecase) {
7473             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7474             }
7475 0         0 }
7476 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7477 0         0 $char[$i] = e_capture($1);
7478             if ($ignorecase) {
7479             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7480             }
7481             }
7482              
7483 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7484 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) {
7485 0         0 $char[$i] = e_capture($1.'->'.$2);
7486             if ($ignorecase) {
7487             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7488             }
7489             }
7490              
7491 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7492 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) {
7493 0         0 $char[$i] = e_capture($1.'->'.$2);
7494             if ($ignorecase) {
7495             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7496             }
7497             }
7498              
7499 0         0 # $$foo
7500 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7501 0         0 $char[$i] = e_capture($1);
7502             if ($ignorecase) {
7503             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7504             }
7505             }
7506              
7507 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
7508 12         34 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7509             if ($ignorecase) {
7510             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
7511 0         0 }
7512             else {
7513             $char[$i] = '@{[Elatin5::PREMATCH()]}';
7514             }
7515             }
7516              
7517 12 50       51 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
7518 12         35 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7519             if ($ignorecase) {
7520             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
7521 0         0 }
7522             else {
7523             $char[$i] = '@{[Elatin5::MATCH()]}';
7524             }
7525             }
7526              
7527 12 50       51 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
7528 9         25 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7529             if ($ignorecase) {
7530             $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
7531 0         0 }
7532             else {
7533             $char[$i] = '@{[Elatin5::POSTMATCH()]}';
7534             }
7535             }
7536              
7537 9 0       41 # ${ foo }
7538 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) {
7539             if ($ignorecase) {
7540             $char[$i] = '@{[Elatin5::ignorecase(' . $1 . ')]}';
7541             }
7542             }
7543              
7544 0         0 # ${ ... }
7545 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7546 0         0 $char[$i] = e_capture($1);
7547             if ($ignorecase) {
7548             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7549             }
7550             }
7551              
7552 0         0 # $scalar or @array
7553 3 50       10 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7554 3         11 $char[$i] = e_string($char[$i]);
7555             if ($ignorecase) {
7556             $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7557             }
7558             }
7559              
7560 0 50       0 # quote character before ? + * {
7561             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7562             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7563 1         9 }
7564             else {
7565             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7566             }
7567             }
7568             }
7569 0         0  
7570 74 50       207 # make regexp string
7571 74         156 $modifier =~ tr/i//d;
7572             if ($left_e > $right_e) {
7573 0         0 return join '', 'Elatin5::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7574             }
7575             return join '', 'Elatin5::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7576             }
7577              
7578             #
7579             # escape regexp of split qr''
7580 74     0 0 722 #
7581 0   0       sub e_split_q {
7582             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7583 0           $modifier ||= '';
7584 0 0          
7585 0           $modifier =~ tr/p//d;
7586 0           if ($modifier =~ /([adlu])/oxms) {
7587 0 0         my $line = 0;
7588 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7589 0           if ($filename ne __FILE__) {
7590             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7591             last;
7592 0           }
7593             }
7594             die qq{Unsupported modifier "$1" used at line $line.\n};
7595 0           }
7596              
7597             $slash = 'div';
7598 0 0          
7599 0           # /b /B modifier
7600             if ($modifier =~ tr/bB//d) {
7601             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7602 0 0         }
7603              
7604             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7605 0            
7606             # split regexp
7607             my @char = $string =~ /\G((?>
7608             [^\\\[] |
7609             [\x00-\xFF] |
7610             \[\^ |
7611             \[\: (?>[a-z]+) \:\] |
7612             \[\:\^ (?>[a-z]+) \:\] |
7613             \\ (?:$q_char) |
7614             (?:$q_char)
7615             ))/oxmsg;
7616 0            
7617 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7618             for (my $i=0; $i <= $#char; $i++) {
7619             if (0) {
7620             }
7621 0            
7622 0           # open character class [...]
7623 0 0         elsif ($char[$i] eq '[') {
7624 0           my $left = $i;
7625             if ($char[$i+1] eq ']') {
7626 0           $i++;
7627 0 0         }
7628 0           while (1) {
7629             if (++$i > $#char) {
7630 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7631 0           }
7632             if ($char[$i] eq ']') {
7633             my $right = $i;
7634 0            
7635             # [...]
7636 0           splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
7637 0            
7638             $i = $left;
7639             last;
7640             }
7641             }
7642             }
7643              
7644 0           # open character class [^...]
7645 0 0         elsif ($char[$i] eq '[^') {
7646 0           my $left = $i;
7647             if ($char[$i+1] eq ']') {
7648 0           $i++;
7649 0 0         }
7650 0           while (1) {
7651             if (++$i > $#char) {
7652 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7653 0           }
7654             if ($char[$i] eq ']') {
7655             my $right = $i;
7656 0            
7657             # [^...]
7658 0           splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7659 0            
7660             $i = $left;
7661             last;
7662             }
7663             }
7664             }
7665              
7666 0           # rewrite character class or escape character
7667             elsif (my $char = character_class($char[$i],$modifier)) {
7668             $char[$i] = $char;
7669             }
7670              
7671 0           # split(m/^/) --> split(m/^/m)
7672             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7673             $modifier .= 'm';
7674             }
7675              
7676 0 0         # /i modifier
7677 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
7678             if (CORE::length(Elatin5::fc($char[$i])) == 1) {
7679             $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
7680 0           }
7681             else {
7682             $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
7683             }
7684             }
7685              
7686 0 0         # quote character before ? + * {
7687             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7688             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7689 0           }
7690             else {
7691             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7692             }
7693             }
7694 0           }
7695 0            
7696             $modifier =~ tr/i//d;
7697             return join '', 'Elatin5::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7698             }
7699              
7700             #
7701             # instead of Carp::carp
7702 0     0 0   #
7703 0           sub carp {
7704             my($package,$filename,$line) = caller(1);
7705             print STDERR "@_ at $filename line $line.\n";
7706             }
7707              
7708             #
7709             # instead of Carp::croak
7710 0     0 0   #
7711 0           sub croak {
7712 0           my($package,$filename,$line) = caller(1);
7713             print STDERR "@_ at $filename line $line.\n";
7714             die "\n";
7715             }
7716              
7717             #
7718             # instead of Carp::cluck
7719 0     0 0   #
7720 0           sub cluck {
7721 0           my $i = 0;
7722 0           my @cluck = ();
7723 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7724             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7725 0           $i++;
7726 0           }
7727 0           print STDERR CORE::reverse @cluck;
7728             print STDERR "\n";
7729             print STDERR @_;
7730             }
7731              
7732             #
7733             # instead of Carp::confess
7734 0     0 0   #
7735 0           sub confess {
7736 0           my $i = 0;
7737 0           my @confess = ();
7738 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7739             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7740 0           $i++;
7741 0           }
7742 0           print STDERR CORE::reverse @confess;
7743 0           print STDERR "\n";
7744             print STDERR @_;
7745             die "\n";
7746             }
7747              
7748             1;
7749              
7750             __END__