File Coverage

blib/lib/Elatin4.pm
Criterion Covered Total %
statement 865 3080 28.0
branch 944 2674 35.3
condition 99 373 26.5
subroutine 67 125 53.6
pod 7 74 9.4
total 1982 6326 31.3


line stmt bran cond sub pod time code
1             package Elatin4;
2             ######################################################################
3             #
4             # Elatin4 - Run-time routines for Latin4.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin4/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   3389 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         578  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             # 12.3. Delaying use Until Runtime
15             # in Chapter 12. Packages, Libraries, and Modules
16             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
17             # (and so on)
18              
19             # Version numbers should be boring
20             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
21             # For the impatient, the disinterested or those who just want to follow
22             # a recipe, my advice for all modules is this:
23             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
24             # $VERSION = eval $VERSION;
25              
26 200     200   12678 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1014  
  200         582  
  200         28796  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1167 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         276 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         25959 if (CORE::ord('A') != 0x41) {
38             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
39             }
40             }
41              
42             BEGIN {
43              
44             # instead of utf8.pm
45 200     200   12598 CORE::eval q{
  200     200   1060  
  200     73   304  
  200         23756  
  52         4518  
  51         4655  
  48         4391  
  49         4617  
46             no warnings qw(redefine);
47             *utf8::upgrade = sub { CORE::length $_[0] };
48             *utf8::downgrade = sub { 1 };
49             *utf8::encode = sub { };
50             *utf8::decode = sub { 1 };
51             *utf8::is_utf8 = sub { };
52             *utf8::valid = sub { 1 };
53             };
54 200 50       98513 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65 0         0 BEGIN {
66 200     200   469 my $genpkg = "Symbol::";
67 200         8740 my $genseq = 0;
68              
69             sub gensym () {
70 0     0 0 0 my $name = "GEN" . $genseq++;
71              
72             # here, no strict qw(refs); if strict.pm exists
73              
74 0         0 my $ref = \*{$genpkg . $name};
  0         0  
75 0         0 delete $$genpkg{$name};
76 0         0 return $ref;
77             }
78              
79             sub qualify ($;$) {
80 0     0 0 0 my ($name) = @_;
81 0 0 0     0 if (!ref($name) && (Elatin4::index($name, '::') == -1) && (Elatin4::index($name, "'") == -1)) {
      0        
82 0         0 my $pkg;
83 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
84              
85             # Global names: special character, "^xyz", or other.
86 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
89 0         0 $pkg = "main";
90             }
91             else {
92 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
93             }
94 0         0 $name = $pkg . "::" . $name;
95             }
96 0         0 return $name;
97             }
98              
99             sub qualify_to_ref ($;$) {
100              
101             # here, no strict qw(refs); if strict.pm exists
102              
103 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
104             }
105             }
106              
107             # Column: local $@
108             # in Chapter 9. Osaete okitai Perl no kiso
109             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
110             # (and so on)
111              
112             # use strict; if strict.pm exists
113             BEGIN {
114 200 50   200   390 if (CORE::eval { local $@; CORE::require strict }) {
  200         310  
  200         1986  
115 200         22234 strict::->import;
116             }
117             }
118              
119             # P.714 29.2.39. flock
120             # in Chapter 29: Functions
121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
122              
123             # P.863 flock
124             # in Chapter 27: Functions
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126              
127             sub LOCK_SH() {1}
128             sub LOCK_EX() {2}
129             sub LOCK_UN() {8}
130             sub LOCK_NB() {4}
131              
132             # instead of Carp.pm
133             sub carp;
134             sub croak;
135             sub cluck;
136             sub confess;
137              
138             # 6.18. Matching Multiple-Byte Characters
139             # in Chapter 6. Pattern Matching
140             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
141             # (and so on)
142              
143             # regexp of character
144 200     200   13737 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1134  
  200         268  
  200         11190  
145 200     200   11408 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   1112  
  200         272  
  200         23924  
146 200     200   11146 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   891  
  200         301  
  200         13199  
147              
148             #
149             # Latin-4 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   11483 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   900  
  200         252  
  200         356956  
157              
158             #
159             # Latin-4 case conversion
160             #
161             my %lc = ();
162             @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)} =
163             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
164             my %uc = ();
165             @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)} =
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 %fc = ();
168             @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)} =
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              
171             if (0) {
172             }
173              
174             elsif (__PACKAGE__ =~ / \b Elatin4 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-4 | iec[- ]?8859-4 | latin-?4 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA1" => "\xB1", # LATIN LETTER A WITH OGONEK
183             "\xA3" => "\xB3", # LATIN LETTER R WITH CEDILLA
184             "\xA5" => "\xB5", # LATIN LETTER I WITH TILDE
185             "\xA6" => "\xB6", # LATIN LETTER L WITH CEDILLA
186             "\xA9" => "\xB9", # LATIN LETTER S WITH CARON
187             "\xAA" => "\xBA", # LATIN LETTER E WITH MACRON
188             "\xAB" => "\xBB", # LATIN LETTER G WITH CEDILLA
189             "\xAC" => "\xBC", # LATIN LETTER T WITH STROKE
190             "\xAE" => "\xBE", # LATIN LETTER Z WITH CARON
191             "\xBD" => "\xBF", # LATIN LETTER ENG
192             "\xC0" => "\xE0", # LATIN LETTER A WITH MACRON
193             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
194             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
195             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
196             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
197             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
198             "\xC6" => "\xE6", # LATIN LETTER AE
199             "\xC7" => "\xE7", # LATIN LETTER I WITH OGONEK
200             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
201             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
202             "\xCA" => "\xEA", # LATIN LETTER E WITH OGONEK
203             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
204             "\xCC" => "\xEC", # LATIN LETTER E WITH DOT ABOVE
205             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
206             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
207             "\xCF" => "\xEF", # LATIN LETTER I WITH MACRON
208             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
209             "\xD1" => "\xF1", # LATIN LETTER N WITH CEDILLA
210             "\xD2" => "\xF2", # LATIN LETTER O WITH MACRON
211             "\xD3" => "\xF3", # LATIN LETTER K WITH CEDILLA
212             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
213             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
214             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
215             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
216             "\xD9" => "\xF9", # LATIN LETTER U WITH OGONEK
217             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
218             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
219             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
220             "\xDD" => "\xFD", # LATIN LETTER U WITH TILDE
221             "\xDE" => "\xFE", # LATIN LETTER U WITH MACRON
222             );
223              
224             %uc = (%uc,
225             "\xB1" => "\xA1", # LATIN LETTER A WITH OGONEK
226             "\xB3" => "\xA3", # LATIN LETTER R WITH CEDILLA
227             "\xB5" => "\xA5", # LATIN LETTER I WITH TILDE
228             "\xB6" => "\xA6", # LATIN LETTER L WITH CEDILLA
229             "\xB9" => "\xA9", # LATIN LETTER S WITH CARON
230             "\xBA" => "\xAA", # LATIN LETTER E WITH MACRON
231             "\xBB" => "\xAB", # LATIN LETTER G WITH CEDILLA
232             "\xBC" => "\xAC", # LATIN LETTER T WITH STROKE
233             "\xBE" => "\xAE", # LATIN LETTER Z WITH CARON
234             "\xBF" => "\xBD", # LATIN LETTER ENG
235             "\xE0" => "\xC0", # LATIN LETTER A WITH MACRON
236             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
237             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
238             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
239             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
240             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
241             "\xE6" => "\xC6", # LATIN LETTER AE
242             "\xE7" => "\xC7", # LATIN LETTER I WITH OGONEK
243             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
244             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
245             "\xEA" => "\xCA", # LATIN LETTER E WITH OGONEK
246             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
247             "\xEC" => "\xCC", # LATIN LETTER E WITH DOT ABOVE
248             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
249             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
250             "\xEF" => "\xCF", # LATIN LETTER I WITH MACRON
251             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
252             "\xF1" => "\xD1", # LATIN LETTER N WITH CEDILLA
253             "\xF2" => "\xD2", # LATIN LETTER O WITH MACRON
254             "\xF3" => "\xD3", # LATIN LETTER K WITH CEDILLA
255             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
256             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
257             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
258             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
259             "\xF9" => "\xD9", # LATIN LETTER U WITH OGONEK
260             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
261             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
262             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
263             "\xFD" => "\xDD", # LATIN LETTER U WITH TILDE
264             "\xFE" => "\xDE", # LATIN LETTER U WITH MACRON
265             );
266              
267             %fc = (%fc,
268             "\xA1" => "\xB1", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
269             "\xA3" => "\xB3", # LATIN CAPITAL LETTER R WITH CEDILLA --> LATIN SMALL LETTER R WITH CEDILLA
270             "\xA5" => "\xB5", # LATIN CAPITAL LETTER I WITH TILDE --> LATIN SMALL LETTER I WITH TILDE
271             "\xA6" => "\xB6", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
272             "\xA9" => "\xB9", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
273             "\xAA" => "\xBA", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
274             "\xAB" => "\xBB", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
275             "\xAC" => "\xBC", # LATIN CAPITAL LETTER T WITH STROKE --> LATIN SMALL LETTER T WITH STROKE
276             "\xAE" => "\xBE", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
277             "\xBD" => "\xBF", # LATIN CAPITAL LETTER ENG --> LATIN SMALL LETTER ENG
278             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
279             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
280             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
281             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
282             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
283             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
284             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
285             "\xC7" => "\xE7", # LATIN CAPITAL LETTER I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
286             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
287             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
288             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
289             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
290             "\xCC" => "\xEC", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
291             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
292             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
293             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
294             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
295             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
296             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
297             "\xD3" => "\xF3", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
298             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
299             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
300             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
301             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
302             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
303             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
304             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
305             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
306             "\xDD" => "\xFD", # LATIN CAPITAL LETTER U WITH TILDE --> LATIN SMALL LETTER U WITH TILDE
307             "\xDE" => "\xFE", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
308             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
309             );
310             }
311              
312             else {
313             croak "Don't know my package name '@{[__PACKAGE__]}'";
314             }
315              
316             #
317             # @ARGV wildcard globbing
318             #
319             sub import {
320              
321 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
322 0         0 my @argv = ();
323 0         0 for (@ARGV) {
324              
325             # has space
326 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
327 0 0       0 if (my @glob = Elatin4::glob(qq{"$_"})) {
328 0         0 push @argv, @glob;
329             }
330             else {
331 0         0 push @argv, $_;
332             }
333             }
334              
335             # has wildcard metachar
336             elsif (/\A (?:$q_char)*? [*?] /oxms) {
337 0 0       0 if (my @glob = Elatin4::glob($_)) {
338 0         0 push @argv, @glob;
339             }
340             else {
341 0         0 push @argv, $_;
342             }
343             }
344              
345             # no wildcard globbing
346             else {
347 0         0 push @argv, $_;
348             }
349             }
350 0         0 @ARGV = @argv;
351             }
352              
353 0         0 *Char::ord = \&Latin4::ord;
354 0         0 *Char::ord_ = \&Latin4::ord_;
355 0         0 *Char::reverse = \&Latin4::reverse;
356 0         0 *Char::getc = \&Latin4::getc;
357 0         0 *Char::length = \&Latin4::length;
358 0         0 *Char::substr = \&Latin4::substr;
359 0         0 *Char::index = \&Latin4::index;
360 0         0 *Char::rindex = \&Latin4::rindex;
361 0         0 *Char::eval = \&Latin4::eval;
362 0         0 *Char::escape = \&Latin4::escape;
363 0         0 *Char::escape_token = \&Latin4::escape_token;
364 0         0 *Char::escape_script = \&Latin4::escape_script;
365             }
366              
367             # P.230 Care with Prototypes
368             # in Chapter 6: Subroutines
369             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
370             #
371             # If you aren't careful, you can get yourself into trouble with prototypes.
372             # But if you are careful, you can do a lot of neat things with them. This is
373             # all very powerful, of course, and should only be used in moderation to make
374             # the world a better place.
375              
376             # P.332 Care with Prototypes
377             # in Chapter 7: Subroutines
378             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
379             #
380             # If you aren't careful, you can get yourself into trouble with prototypes.
381             # But if you are careful, you can do a lot of neat things with them. This is
382             # all very powerful, of course, and should only be used in moderation to make
383             # the world a better place.
384              
385             #
386             # Prototypes of subroutines
387             #
388       0     sub unimport {}
389             sub Elatin4::split(;$$$);
390             sub Elatin4::tr($$$$;$);
391             sub Elatin4::chop(@);
392             sub Elatin4::index($$;$);
393             sub Elatin4::rindex($$;$);
394             sub Elatin4::lcfirst(@);
395             sub Elatin4::lcfirst_();
396             sub Elatin4::lc(@);
397             sub Elatin4::lc_();
398             sub Elatin4::ucfirst(@);
399             sub Elatin4::ucfirst_();
400             sub Elatin4::uc(@);
401             sub Elatin4::uc_();
402             sub Elatin4::fc(@);
403             sub Elatin4::fc_();
404             sub Elatin4::ignorecase;
405             sub Elatin4::classic_character_class;
406             sub Elatin4::capture;
407             sub Elatin4::chr(;$);
408             sub Elatin4::chr_();
409             sub Elatin4::glob($);
410             sub Elatin4::glob_();
411              
412             sub Latin4::ord(;$);
413             sub Latin4::ord_();
414             sub Latin4::reverse(@);
415             sub Latin4::getc(;*@);
416             sub Latin4::length(;$);
417             sub Latin4::substr($$;$$);
418             sub Latin4::index($$;$);
419             sub Latin4::rindex($$;$);
420             sub Latin4::escape(;$);
421              
422             #
423             # Regexp work
424             #
425 200     200   14275 BEGIN { CORE::eval q{ use vars qw(
  200     200   1149  
  200         329  
  200         72779  
426             $Latin4::re_a
427             $Latin4::re_t
428             $Latin4::re_n
429             $Latin4::re_r
430             ) } }
431              
432             #
433             # Character class
434             #
435 200     200   15001 BEGIN { CORE::eval q{ use vars qw(
  200     200   1024  
  200         303  
  200         2518883  
436             $dot
437             $dot_s
438             $eD
439             $eS
440             $eW
441             $eH
442             $eV
443             $eR
444             $eN
445             $not_alnum
446             $not_alpha
447             $not_ascii
448             $not_blank
449             $not_cntrl
450             $not_digit
451             $not_graph
452             $not_lower
453             $not_lower_i
454             $not_print
455             $not_punct
456             $not_space
457             $not_upper
458             $not_upper_i
459             $not_word
460             $not_xdigit
461             $eb
462             $eB
463             ) } }
464              
465             ${Elatin4::dot} = qr{(?>[^\x0A])};
466             ${Elatin4::dot_s} = qr{(?>[\x00-\xFF])};
467             ${Elatin4::eD} = qr{(?>[^0-9])};
468              
469             # Vertical tabs are now whitespace
470             # \s in a regex now matches a vertical tab in all circumstances.
471             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
472             # ${Elatin4::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
473             # ${Elatin4::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
474             ${Elatin4::eS} = qr{(?>[^\s])};
475              
476             ${Elatin4::eW} = qr{(?>[^0-9A-Z_a-z])};
477             ${Elatin4::eH} = qr{(?>[^\x09\x20])};
478             ${Elatin4::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
479             ${Elatin4::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
480             ${Elatin4::eN} = qr{(?>[^\x0A])};
481             ${Elatin4::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
482             ${Elatin4::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
483             ${Elatin4::not_ascii} = qr{(?>[^\x00-\x7F])};
484             ${Elatin4::not_blank} = qr{(?>[^\x09\x20])};
485             ${Elatin4::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
486             ${Elatin4::not_digit} = qr{(?>[^\x30-\x39])};
487             ${Elatin4::not_graph} = qr{(?>[^\x21-\x7F])};
488             ${Elatin4::not_lower} = qr{(?>[^\x61-\x7A])};
489             ${Elatin4::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
490             # ${Elatin4::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
491             ${Elatin4::not_print} = qr{(?>[^\x20-\x7F])};
492             ${Elatin4::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
493             ${Elatin4::not_space} = qr{(?>[^\s\x0B])};
494             ${Elatin4::not_upper} = qr{(?>[^\x41-\x5A])};
495             ${Elatin4::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
496             # ${Elatin4::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
497             ${Elatin4::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
498             ${Elatin4::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
499             ${Elatin4::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))};
500             ${Elatin4::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]))};
501              
502             # avoid: Name "Elatin4::foo" used only once: possible typo at here.
503             ${Elatin4::dot} = ${Elatin4::dot};
504             ${Elatin4::dot_s} = ${Elatin4::dot_s};
505             ${Elatin4::eD} = ${Elatin4::eD};
506             ${Elatin4::eS} = ${Elatin4::eS};
507             ${Elatin4::eW} = ${Elatin4::eW};
508             ${Elatin4::eH} = ${Elatin4::eH};
509             ${Elatin4::eV} = ${Elatin4::eV};
510             ${Elatin4::eR} = ${Elatin4::eR};
511             ${Elatin4::eN} = ${Elatin4::eN};
512             ${Elatin4::not_alnum} = ${Elatin4::not_alnum};
513             ${Elatin4::not_alpha} = ${Elatin4::not_alpha};
514             ${Elatin4::not_ascii} = ${Elatin4::not_ascii};
515             ${Elatin4::not_blank} = ${Elatin4::not_blank};
516             ${Elatin4::not_cntrl} = ${Elatin4::not_cntrl};
517             ${Elatin4::not_digit} = ${Elatin4::not_digit};
518             ${Elatin4::not_graph} = ${Elatin4::not_graph};
519             ${Elatin4::not_lower} = ${Elatin4::not_lower};
520             ${Elatin4::not_lower_i} = ${Elatin4::not_lower_i};
521             ${Elatin4::not_print} = ${Elatin4::not_print};
522             ${Elatin4::not_punct} = ${Elatin4::not_punct};
523             ${Elatin4::not_space} = ${Elatin4::not_space};
524             ${Elatin4::not_upper} = ${Elatin4::not_upper};
525             ${Elatin4::not_upper_i} = ${Elatin4::not_upper_i};
526             ${Elatin4::not_word} = ${Elatin4::not_word};
527             ${Elatin4::not_xdigit} = ${Elatin4::not_xdigit};
528             ${Elatin4::eb} = ${Elatin4::eb};
529             ${Elatin4::eB} = ${Elatin4::eB};
530              
531             #
532             # Latin-4 split
533             #
534             sub Elatin4::split(;$$$) {
535              
536             # P.794 29.2.161. split
537             # in Chapter 29: Functions
538             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
539              
540             # P.951 split
541             # in Chapter 27: Functions
542             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
543              
544 0     0 0 0 my $pattern = $_[0];
545 0         0 my $string = $_[1];
546 0         0 my $limit = $_[2];
547              
548             # if $pattern is also omitted or is the literal space, " "
549 0 0       0 if (not defined $pattern) {
550 0         0 $pattern = ' ';
551             }
552              
553             # if $string is omitted, the function splits the $_ string
554 0 0       0 if (not defined $string) {
555 0 0       0 if (defined $_) {
556 0         0 $string = $_;
557             }
558             else {
559 0         0 $string = '';
560             }
561             }
562              
563 0         0 my @split = ();
564              
565             # when string is empty
566 0 0       0 if ($string eq '') {
    0          
567              
568             # resulting list value in list context
569 0 0       0 if (wantarray) {
570 0         0 return @split;
571             }
572              
573             # count of substrings in scalar context
574             else {
575 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
576 0         0 @_ = @split;
577 0         0 return scalar @_;
578             }
579             }
580              
581             # split's first argument is more consistently interpreted
582             #
583             # After some changes earlier in v5.17, split's behavior has been simplified:
584             # if the PATTERN argument evaluates to a string containing one space, it is
585             # treated the way that a literal string containing one space once was.
586             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
587              
588             # if $pattern is also omitted or is the literal space, " ", the function splits
589             # on whitespace, /\s+/, after skipping any leading whitespace
590             # (and so on)
591              
592             elsif ($pattern eq ' ') {
593 0 0       0 if (not defined $limit) {
594 0         0 return CORE::split(' ', $string);
595             }
596             else {
597 0         0 return CORE::split(' ', $string, $limit);
598             }
599             }
600              
601             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
602 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
603              
604             # a pattern capable of matching either the null string or something longer than the
605             # null string will split the value of $string into separate characters wherever it
606             # matches the null string between characters
607             # (and so on)
608              
609 0 0       0 if ('' =~ / \A $pattern \z /xms) {
610 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
611 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
612              
613             # P.1024 Appendix W.10 Multibyte Processing
614             # of ISBN 1-56592-224-7 CJKV Information Processing
615             # (and so on)
616              
617             # the //m modifier is assumed when you split on the pattern /^/
618             # (and so on)
619              
620             # V
621 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
622              
623             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
624             # is included in the resulting list, interspersed with the fields that are ordinarily returned
625             # (and so on)
626              
627 0         0 local $@;
628 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
629 0         0 push @split, CORE::eval('$' . $digit);
630             }
631             }
632             }
633              
634             else {
635 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
636              
637             # V
638 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
639 0         0 local $@;
640 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
641 0         0 push @split, CORE::eval('$' . $digit);
642             }
643             }
644             }
645             }
646              
647             elsif ($limit > 0) {
648 0 0       0 if ('' =~ / \A $pattern \z /xms) {
649 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
650 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
651              
652             # V
653 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
654 0         0 local $@;
655 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
656 0         0 push @split, CORE::eval('$' . $digit);
657             }
658             }
659             }
660             }
661             else {
662 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
663 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
664              
665             # V
666 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
667 0         0 local $@;
668 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
669 0         0 push @split, CORE::eval('$' . $digit);
670             }
671             }
672             }
673             }
674             }
675              
676 0 0       0 if (CORE::length($string) > 0) {
677 0         0 push @split, $string;
678             }
679              
680             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
681 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
682 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
683 0         0 pop @split;
684             }
685             }
686              
687             # resulting list value in list context
688 0 0       0 if (wantarray) {
689 0         0 return @split;
690             }
691              
692             # count of substrings in scalar context
693             else {
694 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
695 0         0 @_ = @split;
696 0         0 return scalar @_;
697             }
698             }
699              
700             #
701             # get last subexpression offsets
702             #
703             sub _last_subexpression_offsets {
704 0     0   0 my $pattern = $_[0];
705              
706             # remove comment
707 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
708              
709 0         0 my $modifier = '';
710 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
711 0         0 $modifier = $1;
712 0         0 $modifier =~ s/-[A-Za-z]*//;
713             }
714              
715             # with /x modifier
716 0         0 my @char = ();
717 0 0       0 if ($modifier =~ /x/oxms) {
718 0         0 @char = $pattern =~ /\G((?>
719             [^\\\#\[\(] |
720             \\ $q_char |
721             \# (?>[^\n]*) $ |
722             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
723             \(\? |
724             $q_char
725             ))/oxmsg;
726             }
727              
728             # without /x modifier
729             else {
730 0         0 @char = $pattern =~ /\G((?>
731             [^\\\[\(] |
732             \\ $q_char |
733             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
734             \(\? |
735             $q_char
736             ))/oxmsg;
737             }
738              
739 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
740             }
741              
742             #
743             # Latin-4 transliteration (tr///)
744             #
745             sub Elatin4::tr($$$$;$) {
746              
747 0     0 0 0 my $bind_operator = $_[1];
748 0         0 my $searchlist = $_[2];
749 0         0 my $replacementlist = $_[3];
750 0   0     0 my $modifier = $_[4] || '';
751              
752 0 0       0 if ($modifier =~ /r/oxms) {
753 0 0       0 if ($bind_operator =~ / !~ /oxms) {
754 0         0 croak "Using !~ with tr///r doesn't make sense";
755             }
756             }
757              
758 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
759 0         0 my @searchlist = _charlist_tr($searchlist);
760 0         0 my @replacementlist = _charlist_tr($replacementlist);
761              
762 0         0 my %tr = ();
763 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
764 0 0       0 if (not exists $tr{$searchlist[$i]}) {
765 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
766 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
767             }
768             elsif ($modifier =~ /d/oxms) {
769 0         0 $tr{$searchlist[$i]} = '';
770             }
771             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
772 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
773             }
774             else {
775 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
776             }
777             }
778             }
779              
780 0         0 my $tr = 0;
781 0         0 my $replaced = '';
782 0 0       0 if ($modifier =~ /c/oxms) {
783 0         0 while (defined(my $char = shift @char)) {
784 0 0       0 if (not exists $tr{$char}) {
785 0 0       0 if (defined $replacementlist[0]) {
786 0         0 $replaced .= $replacementlist[0];
787             }
788 0         0 $tr++;
789 0 0       0 if ($modifier =~ /s/oxms) {
790 0   0     0 while (@char and (not exists $tr{$char[0]})) {
791 0         0 shift @char;
792 0         0 $tr++;
793             }
794             }
795             }
796             else {
797 0         0 $replaced .= $char;
798             }
799             }
800             }
801             else {
802 0         0 while (defined(my $char = shift @char)) {
803 0 0       0 if (exists $tr{$char}) {
804 0         0 $replaced .= $tr{$char};
805 0         0 $tr++;
806 0 0       0 if ($modifier =~ /s/oxms) {
807 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
808 0         0 shift @char;
809 0         0 $tr++;
810             }
811             }
812             }
813             else {
814 0         0 $replaced .= $char;
815             }
816             }
817             }
818              
819 0 0       0 if ($modifier =~ /r/oxms) {
820 0         0 return $replaced;
821             }
822             else {
823 0         0 $_[0] = $replaced;
824 0 0       0 if ($bind_operator =~ / !~ /oxms) {
825 0         0 return not $tr;
826             }
827             else {
828 0         0 return $tr;
829             }
830             }
831             }
832              
833             #
834             # Latin-4 chop
835             #
836             sub Elatin4::chop(@) {
837              
838 0     0 0 0 my $chop;
839 0 0       0 if (@_ == 0) {
840 0         0 my @char = /\G (?>$q_char) /oxmsg;
841 0         0 $chop = pop @char;
842 0         0 $_ = join '', @char;
843             }
844             else {
845 0         0 for (@_) {
846 0         0 my @char = /\G (?>$q_char) /oxmsg;
847 0         0 $chop = pop @char;
848 0         0 $_ = join '', @char;
849             }
850             }
851 0         0 return $chop;
852             }
853              
854             #
855             # Latin-4 index by octet
856             #
857             sub Elatin4::index($$;$) {
858              
859 0     0 1 0 my($str,$substr,$position) = @_;
860 0   0     0 $position ||= 0;
861 0         0 my $pos = 0;
862              
863 0         0 while ($pos < CORE::length($str)) {
864 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
865 0 0       0 if ($pos >= $position) {
866 0         0 return $pos;
867             }
868             }
869 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
870 0         0 $pos += CORE::length($1);
871             }
872             else {
873 0         0 $pos += 1;
874             }
875             }
876 0         0 return -1;
877             }
878              
879             #
880             # Latin-4 reverse index
881             #
882             sub Elatin4::rindex($$;$) {
883              
884 0     0 0 0 my($str,$substr,$position) = @_;
885 0   0     0 $position ||= CORE::length($str) - 1;
886 0         0 my $pos = 0;
887 0         0 my $rindex = -1;
888              
889 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
890 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
891 0         0 $rindex = $pos;
892             }
893 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
894 0         0 $pos += CORE::length($1);
895             }
896             else {
897 0         0 $pos += 1;
898             }
899             }
900 0         0 return $rindex;
901             }
902              
903             #
904             # Latin-4 lower case first with parameter
905             #
906             sub Elatin4::lcfirst(@) {
907 0 0   0 0 0 if (@_) {
908 0         0 my $s = shift @_;
909 0 0 0     0 if (@_ and wantarray) {
910 0         0 return Elatin4::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
911             }
912             else {
913 0         0 return Elatin4::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
914             }
915             }
916             else {
917 0         0 return Elatin4::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
918             }
919             }
920              
921             #
922             # Latin-4 lower case first without parameter
923             #
924             sub Elatin4::lcfirst_() {
925 0     0 0 0 return Elatin4::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
926             }
927              
928             #
929             # Latin-4 lower case with parameter
930             #
931             sub Elatin4::lc(@) {
932 0 0   0 0 0 if (@_) {
933 0         0 my $s = shift @_;
934 0 0 0     0 if (@_ and wantarray) {
935 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
936             }
937             else {
938 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
939             }
940             }
941             else {
942 0         0 return Elatin4::lc_();
943             }
944             }
945              
946             #
947             # Latin-4 lower case without parameter
948             #
949             sub Elatin4::lc_() {
950 0     0 0 0 my $s = $_;
951 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
952             }
953              
954             #
955             # Latin-4 upper case first with parameter
956             #
957             sub Elatin4::ucfirst(@) {
958 0 0   0 0 0 if (@_) {
959 0         0 my $s = shift @_;
960 0 0 0     0 if (@_ and wantarray) {
961 0         0 return Elatin4::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
962             }
963             else {
964 0         0 return Elatin4::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
965             }
966             }
967             else {
968 0         0 return Elatin4::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
969             }
970             }
971              
972             #
973             # Latin-4 upper case first without parameter
974             #
975             sub Elatin4::ucfirst_() {
976 0     0 0 0 return Elatin4::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
977             }
978              
979             #
980             # Latin-4 upper case with parameter
981             #
982             sub Elatin4::uc(@) {
983 174 50   174 0 311 if (@_) {
984 174         180 my $s = shift @_;
985 174 50 33     430 if (@_ and wantarray) {
986 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
987             }
988             else {
989 174 100       572 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         647  
990             }
991             }
992             else {
993 0         0 return Elatin4::uc_();
994             }
995             }
996              
997             #
998             # Latin-4 upper case without parameter
999             #
1000             sub Elatin4::uc_() {
1001 0     0 0 0 my $s = $_;
1002 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1003             }
1004              
1005             #
1006             # Latin-4 fold case with parameter
1007             #
1008             sub Elatin4::fc(@) {
1009 197 50   197 0 292 if (@_) {
1010 197         201 my $s = shift @_;
1011 197 50 33     393 if (@_ and wantarray) {
1012 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1013             }
1014             else {
1015 197 100       659 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         5125  
1016             }
1017             }
1018             else {
1019 0         0 return Elatin4::fc_();
1020             }
1021             }
1022              
1023             #
1024             # Latin-4 fold case without parameter
1025             #
1026             sub Elatin4::fc_() {
1027 0     0 0 0 my $s = $_;
1028 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1029             }
1030              
1031             #
1032             # Latin-4 regexp capture
1033             #
1034             {
1035             sub Elatin4::capture {
1036 0     0 1 0 return $_[0];
1037             }
1038             }
1039              
1040             #
1041             # Latin-4 regexp ignore case modifier
1042             #
1043             sub Elatin4::ignorecase {
1044              
1045 0     0 0 0 my @string = @_;
1046 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1047              
1048             # ignore case of $scalar or @array
1049 0         0 for my $string (@string) {
1050              
1051             # split regexp
1052 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1053              
1054             # unescape character
1055 0         0 for (my $i=0; $i <= $#char; $i++) {
1056 0 0       0 next if not defined $char[$i];
1057              
1058             # open character class [...]
1059 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1060 0         0 my $left = $i;
1061              
1062             # [] make die "unmatched [] in regexp ...\n"
1063              
1064 0 0       0 if ($char[$i+1] eq ']') {
1065 0         0 $i++;
1066             }
1067              
1068 0         0 while (1) {
1069 0 0       0 if (++$i > $#char) {
1070 0         0 croak "Unmatched [] in regexp";
1071             }
1072 0 0       0 if ($char[$i] eq ']') {
1073 0         0 my $right = $i;
1074 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1075              
1076             # escape character
1077 0         0 for my $char (@charlist) {
1078 0 0       0 if (0) {
1079             }
1080              
1081 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1082 0         0 $char = '\\' . $char;
1083             }
1084             }
1085              
1086             # [...]
1087 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1088              
1089 0         0 $i = $left;
1090 0         0 last;
1091             }
1092             }
1093             }
1094              
1095             # open character class [^...]
1096             elsif ($char[$i] eq '[^') {
1097 0         0 my $left = $i;
1098              
1099             # [^] make die "unmatched [] in regexp ...\n"
1100              
1101 0 0       0 if ($char[$i+1] eq ']') {
1102 0         0 $i++;
1103             }
1104              
1105 0         0 while (1) {
1106 0 0       0 if (++$i > $#char) {
1107 0         0 croak "Unmatched [] in regexp";
1108             }
1109 0 0       0 if ($char[$i] eq ']') {
1110 0         0 my $right = $i;
1111 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1112              
1113             # escape character
1114 0         0 for my $char (@charlist) {
1115 0 0       0 if (0) {
1116             }
1117              
1118 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1119 0         0 $char = '\\' . $char;
1120             }
1121             }
1122              
1123             # [^...]
1124 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1125              
1126 0         0 $i = $left;
1127 0         0 last;
1128             }
1129             }
1130             }
1131              
1132             # rewrite classic character class or escape character
1133             elsif (my $char = classic_character_class($char[$i])) {
1134 0         0 $char[$i] = $char;
1135             }
1136              
1137             # with /i modifier
1138             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1139 0         0 my $uc = Elatin4::uc($char[$i]);
1140 0         0 my $fc = Elatin4::fc($char[$i]);
1141 0 0       0 if ($uc ne $fc) {
1142 0 0       0 if (CORE::length($fc) == 1) {
1143 0         0 $char[$i] = '[' . $uc . $fc . ']';
1144             }
1145             else {
1146 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1147             }
1148             }
1149             }
1150             }
1151              
1152             # characterize
1153 0         0 for (my $i=0; $i <= $#char; $i++) {
1154 0 0       0 next if not defined $char[$i];
1155              
1156 0 0       0 if (0) {
1157             }
1158              
1159             # quote character before ? + * {
1160 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1161 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1162 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1163             }
1164             }
1165             }
1166              
1167 0         0 $string = join '', @char;
1168             }
1169              
1170             # make regexp string
1171 0         0 return @string;
1172             }
1173              
1174             #
1175             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1176             #
1177             sub Elatin4::classic_character_class {
1178 1862     1862 0 1839 my($char) = @_;
1179              
1180             return {
1181             '\D' => '${Elatin4::eD}',
1182             '\S' => '${Elatin4::eS}',
1183             '\W' => '${Elatin4::eW}',
1184             '\d' => '[0-9]',
1185              
1186             # Before Perl 5.6, \s only matched the five whitespace characters
1187             # tab, newline, form-feed, carriage return, and the space character
1188             # itself, which, taken together, is the character class [\t\n\f\r ].
1189              
1190             # Vertical tabs are now whitespace
1191             # \s in a regex now matches a vertical tab in all circumstances.
1192             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1193             # \t \n \v \f \r space
1194             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1195             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1196             '\s' => '\s',
1197              
1198             '\w' => '[0-9A-Z_a-z]',
1199             '\C' => '[\x00-\xFF]',
1200             '\X' => 'X',
1201              
1202             # \h \v \H \V
1203              
1204             # P.114 Character Class Shortcuts
1205             # in Chapter 7: In the World of Regular Expressions
1206             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1207              
1208             # P.357 13.2.3 Whitespace
1209             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1210             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1211             #
1212             # 0x00009 CHARACTER TABULATION h s
1213             # 0x0000a LINE FEED (LF) vs
1214             # 0x0000b LINE TABULATION v
1215             # 0x0000c FORM FEED (FF) vs
1216             # 0x0000d CARRIAGE RETURN (CR) vs
1217             # 0x00020 SPACE h s
1218              
1219             # P.196 Table 5-9. Alphanumeric regex metasymbols
1220             # in Chapter 5. Pattern Matching
1221             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1222              
1223             # (and so on)
1224              
1225             '\H' => '${Elatin4::eH}',
1226             '\V' => '${Elatin4::eV}',
1227             '\h' => '[\x09\x20]',
1228             '\v' => '[\x0A\x0B\x0C\x0D]',
1229             '\R' => '${Elatin4::eR}',
1230              
1231             # \N
1232             #
1233             # http://perldoc.perl.org/perlre.html
1234             # Character Classes and other Special Escapes
1235             # Any character but \n (experimental). Not affected by /s modifier
1236              
1237             '\N' => '${Elatin4::eN}',
1238              
1239             # \b \B
1240              
1241             # P.180 Boundaries: The \b and \B Assertions
1242             # in Chapter 5: Pattern Matching
1243             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1244              
1245             # P.219 Boundaries: The \b and \B Assertions
1246             # in Chapter 5: Pattern Matching
1247             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1248              
1249             # \b really means (?:(?<=\w)(?!\w)|(?
1250             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1251             '\b' => '${Elatin4::eb}',
1252              
1253             # \B really means (?:(?<=\w)(?=\w)|(?
1254             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1255             '\B' => '${Elatin4::eB}',
1256              
1257 1862   100     83464 }->{$char} || '';
1258             }
1259              
1260             #
1261             # prepare Latin-4 characters per length
1262             #
1263              
1264             # 1 octet characters
1265             my @chars1 = ();
1266             sub chars1 {
1267 0 0   0 0 0 if (@chars1) {
1268 0         0 return @chars1;
1269             }
1270 0 0       0 if (exists $range_tr{1}) {
1271 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1272 0         0 while (my @range = splice(@ranges,0,1)) {
1273 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1274 0         0 push @chars1, pack 'C', $oct0;
1275             }
1276             }
1277             }
1278 0         0 return @chars1;
1279             }
1280              
1281             # 2 octets characters
1282             my @chars2 = ();
1283             sub chars2 {
1284 0 0   0 0 0 if (@chars2) {
1285 0         0 return @chars2;
1286             }
1287 0 0       0 if (exists $range_tr{2}) {
1288 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1289 0         0 while (my @range = splice(@ranges,0,2)) {
1290 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1291 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1292 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1293             }
1294             }
1295             }
1296             }
1297 0         0 return @chars2;
1298             }
1299              
1300             # 3 octets characters
1301             my @chars3 = ();
1302             sub chars3 {
1303 0 0   0 0 0 if (@chars3) {
1304 0         0 return @chars3;
1305             }
1306 0 0       0 if (exists $range_tr{3}) {
1307 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1308 0         0 while (my @range = splice(@ranges,0,3)) {
1309 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1310 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1311 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1312 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1313             }
1314             }
1315             }
1316             }
1317             }
1318 0         0 return @chars3;
1319             }
1320              
1321             # 4 octets characters
1322             my @chars4 = ();
1323             sub chars4 {
1324 0 0   0 0 0 if (@chars4) {
1325 0         0 return @chars4;
1326             }
1327 0 0       0 if (exists $range_tr{4}) {
1328 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1329 0         0 while (my @range = splice(@ranges,0,4)) {
1330 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1331 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1332 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1333 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1334 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1335             }
1336             }
1337             }
1338             }
1339             }
1340             }
1341 0         0 return @chars4;
1342             }
1343              
1344             #
1345             # Latin-4 open character list for tr
1346             #
1347             sub _charlist_tr {
1348              
1349 0     0   0 local $_ = shift @_;
1350              
1351             # unescape character
1352 0         0 my @char = ();
1353 0         0 while (not /\G \z/oxmsgc) {
1354 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1355 0         0 push @char, '\-';
1356             }
1357             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1358 0         0 push @char, CORE::chr(oct $1);
1359             }
1360             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1361 0         0 push @char, CORE::chr(hex $1);
1362             }
1363             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1364 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1365             }
1366             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1367             push @char, {
1368             '\0' => "\0",
1369             '\n' => "\n",
1370             '\r' => "\r",
1371             '\t' => "\t",
1372             '\f' => "\f",
1373             '\b' => "\x08", # \b means backspace in character class
1374             '\a' => "\a",
1375             '\e' => "\e",
1376 0         0 }->{$1};
1377             }
1378             elsif (/\G \\ ($q_char) /oxmsgc) {
1379 0         0 push @char, $1;
1380             }
1381             elsif (/\G ($q_char) /oxmsgc) {
1382 0         0 push @char, $1;
1383             }
1384             }
1385              
1386             # join separated multiple-octet
1387 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1388              
1389             # unescape '-'
1390 0         0 my @i = ();
1391 0         0 for my $i (0 .. $#char) {
1392 0 0       0 if ($char[$i] eq '\-') {
    0          
1393 0         0 $char[$i] = '-';
1394             }
1395             elsif ($char[$i] eq '-') {
1396 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1397 0         0 push @i, $i;
1398             }
1399             }
1400             }
1401              
1402             # open character list (reverse for splice)
1403 0         0 for my $i (CORE::reverse @i) {
1404 0         0 my @range = ();
1405              
1406             # range error
1407 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1408 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1409             }
1410              
1411             # range of multiple-octet code
1412 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1413 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1414 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1415             }
1416             elsif (CORE::length($char[$i+1]) == 2) {
1417 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1418 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1419             }
1420             elsif (CORE::length($char[$i+1]) == 3) {
1421 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1422 0         0 push @range, chars2();
1423 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1424             }
1425             elsif (CORE::length($char[$i+1]) == 4) {
1426 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1427 0         0 push @range, chars2();
1428 0         0 push @range, chars3();
1429 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1430             }
1431             else {
1432 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1433             }
1434             }
1435             elsif (CORE::length($char[$i-1]) == 2) {
1436 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1437 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1438             }
1439             elsif (CORE::length($char[$i+1]) == 3) {
1440 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1441 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1442             }
1443             elsif (CORE::length($char[$i+1]) == 4) {
1444 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1445 0         0 push @range, chars3();
1446 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1447             }
1448             else {
1449 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1450             }
1451             }
1452             elsif (CORE::length($char[$i-1]) == 3) {
1453 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1454 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1455             }
1456             elsif (CORE::length($char[$i+1]) == 4) {
1457 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1458 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1459             }
1460             else {
1461 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1462             }
1463             }
1464             elsif (CORE::length($char[$i-1]) == 4) {
1465 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1466 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1467             }
1468             else {
1469 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1470             }
1471             }
1472             else {
1473 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1474             }
1475              
1476 0         0 splice @char, $i-1, 3, @range;
1477             }
1478              
1479 0         0 return @char;
1480             }
1481              
1482             #
1483             # Latin-4 open character class
1484             #
1485             sub _cc {
1486 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1487 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1488             }
1489             elsif (scalar(@_) == 1) {
1490 0         0 return sprintf('\x%02X',$_[0]);
1491             }
1492             elsif (scalar(@_) == 2) {
1493 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1494 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1495             }
1496             elsif ($_[0] == $_[1]) {
1497 0         0 return sprintf('\x%02X',$_[0]);
1498             }
1499             elsif (($_[0]+1) == $_[1]) {
1500 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1501             }
1502             else {
1503 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1504             }
1505             }
1506             else {
1507 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1508             }
1509             }
1510              
1511             #
1512             # Latin-4 octet range
1513             #
1514             sub _octets {
1515 182     182   287 my $length = shift @_;
1516              
1517 182 50       367 if ($length == 1) {
1518 182         583 my($a1) = unpack 'C', $_[0];
1519 182         320 my($z1) = unpack 'C', $_[1];
1520              
1521 182 50       379 if ($a1 > $z1) {
1522 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1523             }
1524              
1525 182 50       536 if ($a1 == $z1) {
    50          
1526 0         0 return sprintf('\x%02X',$a1);
1527             }
1528             elsif (($a1+1) == $z1) {
1529 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1530             }
1531             else {
1532 182         1435 return sprintf('\x%02X-\x%02X',$a1,$z1);
1533             }
1534             }
1535             else {
1536 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1537             }
1538             }
1539              
1540             #
1541             # Latin-4 range regexp
1542             #
1543             sub _range_regexp {
1544 182     182   303 my($length,$first,$last) = @_;
1545              
1546 182         237 my @range_regexp = ();
1547 182 50       537 if (not exists $range_tr{$length}) {
1548 0         0 return @range_regexp;
1549             }
1550              
1551 182         195 my @ranges = @{ $range_tr{$length} };
  182         466  
1552 182         697 while (my @range = splice(@ranges,0,$length)) {
1553 182         243 my $min = '';
1554 182         185 my $max = '';
1555 182         496 for (my $i=0; $i < $length; $i++) {
1556 182         772 $min .= pack 'C', $range[$i][0];
1557 182         552 $max .= pack 'C', $range[$i][-1];
1558             }
1559              
1560             # min___max
1561             # FIRST_____________LAST
1562             # (nothing)
1563              
1564 182 50 33     2543 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1565             }
1566              
1567             # **********
1568             # min_________max
1569             # FIRST_____________LAST
1570             # **********
1571              
1572             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1573 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1574             }
1575              
1576             # **********************
1577             # min________________max
1578             # FIRST_____________LAST
1579             # **********************
1580              
1581             elsif (($min eq $first) and ($max eq $last)) {
1582 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1583             }
1584              
1585             # *********
1586             # min___max
1587             # FIRST_____________LAST
1588             # *********
1589              
1590             elsif (($first le $min) and ($max le $last)) {
1591 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1592             }
1593              
1594             # **********************
1595             # min__________________________max
1596             # FIRST_____________LAST
1597             # **********************
1598              
1599             elsif (($min le $first) and ($last le $max)) {
1600 182         489 push @range_regexp, _octets($length,$first,$last,$min,$max);
1601             }
1602              
1603             # *********
1604             # min________max
1605             # FIRST_____________LAST
1606             # *********
1607              
1608             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1609 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1610             }
1611              
1612             # min___max
1613             # FIRST_____________LAST
1614             # (nothing)
1615              
1616             elsif ($last lt $min) {
1617             }
1618              
1619             else {
1620 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1621             }
1622             }
1623              
1624 182         412 return @range_regexp;
1625             }
1626              
1627             #
1628             # Latin-4 open character list for qr and not qr
1629             #
1630             sub _charlist {
1631              
1632 358     358   521 my $modifier = pop @_;
1633 358         783 my @char = @_;
1634              
1635 358 100       868 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1636              
1637             # unescape character
1638 358         1154 for (my $i=0; $i <= $#char; $i++) {
1639              
1640             # escape - to ...
1641 1125 100 100     10834 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1642 206 100 100     1052 if ((0 < $i) and ($i < $#char)) {
1643 182         434 $char[$i] = '...';
1644             }
1645             }
1646              
1647             # octal escape sequence
1648             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1649 0         0 $char[$i] = octchr($1);
1650             }
1651              
1652             # hexadecimal escape sequence
1653             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1654 0         0 $char[$i] = hexchr($1);
1655             }
1656              
1657             # \b{...} --> b\{...}
1658             # \B{...} --> B\{...}
1659             # \N{CHARNAME} --> N\{CHARNAME}
1660             # \p{PROPERTY} --> p\{PROPERTY}
1661             # \P{PROPERTY} --> P\{PROPERTY}
1662             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1663 0         0 $char[$i] = $1 . '\\' . $2;
1664             }
1665              
1666             # \p, \P, \X --> p, P, X
1667             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1668 0         0 $char[$i] = $1;
1669             }
1670              
1671             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1672 0         0 $char[$i] = CORE::chr oct $1;
1673             }
1674             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1675 22         128 $char[$i] = CORE::chr hex $1;
1676             }
1677             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1678 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1679             }
1680             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1681             $char[$i] = {
1682             '\0' => "\0",
1683             '\n' => "\n",
1684             '\r' => "\r",
1685             '\t' => "\t",
1686             '\f' => "\f",
1687             '\b' => "\x08", # \b means backspace in character class
1688             '\a' => "\a",
1689             '\e' => "\e",
1690             '\d' => '[0-9]',
1691              
1692             # Vertical tabs are now whitespace
1693             # \s in a regex now matches a vertical tab in all circumstances.
1694             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1695             # \t \n \v \f \r space
1696             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1697             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1698             '\s' => '\s',
1699              
1700             '\w' => '[0-9A-Z_a-z]',
1701             '\D' => '${Elatin4::eD}',
1702             '\S' => '${Elatin4::eS}',
1703             '\W' => '${Elatin4::eW}',
1704              
1705             '\H' => '${Elatin4::eH}',
1706             '\V' => '${Elatin4::eV}',
1707             '\h' => '[\x09\x20]',
1708             '\v' => '[\x0A\x0B\x0C\x0D]',
1709             '\R' => '${Elatin4::eR}',
1710              
1711 25         1146 }->{$1};
1712             }
1713              
1714             # POSIX-style character classes
1715             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1716             $char[$i] = {
1717              
1718             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1719             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1720             '[:^lower:]' => '${Elatin4::not_lower_i}',
1721             '[:^upper:]' => '${Elatin4::not_upper_i}',
1722              
1723 8         83 }->{$1};
1724             }
1725             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1726             $char[$i] = {
1727              
1728             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1729             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1730             '[:ascii:]' => '[\x00-\x7F]',
1731             '[:blank:]' => '[\x09\x20]',
1732             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1733             '[:digit:]' => '[\x30-\x39]',
1734             '[:graph:]' => '[\x21-\x7F]',
1735             '[:lower:]' => '[\x61-\x7A]',
1736             '[:print:]' => '[\x20-\x7F]',
1737             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1738              
1739             # P.174 POSIX-Style Character Classes
1740             # in Chapter 5: Pattern Matching
1741             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1742              
1743             # P.311 11.2.4 Character Classes and other Special Escapes
1744             # in Chapter 11: perlre: Perl regular expressions
1745             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1746              
1747             # P.210 POSIX-Style Character Classes
1748             # in Chapter 5: Pattern Matching
1749             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1750              
1751             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1752              
1753             '[:upper:]' => '[\x41-\x5A]',
1754             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1755             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1756             '[:^alnum:]' => '${Elatin4::not_alnum}',
1757             '[:^alpha:]' => '${Elatin4::not_alpha}',
1758             '[:^ascii:]' => '${Elatin4::not_ascii}',
1759             '[:^blank:]' => '${Elatin4::not_blank}',
1760             '[:^cntrl:]' => '${Elatin4::not_cntrl}',
1761             '[:^digit:]' => '${Elatin4::not_digit}',
1762             '[:^graph:]' => '${Elatin4::not_graph}',
1763             '[:^lower:]' => '${Elatin4::not_lower}',
1764             '[:^print:]' => '${Elatin4::not_print}',
1765             '[:^punct:]' => '${Elatin4::not_punct}',
1766             '[:^space:]' => '${Elatin4::not_space}',
1767             '[:^upper:]' => '${Elatin4::not_upper}',
1768             '[:^word:]' => '${Elatin4::not_word}',
1769             '[:^xdigit:]' => '${Elatin4::not_xdigit}',
1770              
1771 70         1489 }->{$1};
1772             }
1773             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1774 7         27 $char[$i] = $1;
1775             }
1776             }
1777              
1778             # open character list
1779 358         579 my @singleoctet = ();
1780 358         459 my @multipleoctet = ();
1781 358         971 for (my $i=0; $i <= $#char; ) {
1782              
1783             # escaped -
1784 943 100 100     4948 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1785 182         206 $i += 1;
1786 182         373 next;
1787             }
1788              
1789             # make range regexp
1790             elsif ($char[$i] eq '...') {
1791              
1792             # range error
1793 182 50       855 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1794 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1795             }
1796             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1797 182 50       498 if ($char[$i-1] gt $char[$i+1]) {
1798 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1799             }
1800             }
1801              
1802             # make range regexp per length
1803 182         628 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1804 182         249 my @regexp = ();
1805              
1806             # is first and last
1807 182 50 33     980 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1808 182         605 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1809             }
1810              
1811             # is first
1812             elsif ($length == CORE::length($char[$i-1])) {
1813 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1814             }
1815              
1816             # is inside in first and last
1817             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1818 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1819             }
1820              
1821             # is last
1822             elsif ($length == CORE::length($char[$i+1])) {
1823 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1824             }
1825              
1826             else {
1827 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1828             }
1829              
1830 182 50       458 if ($length == 1) {
1831 182         524 push @singleoctet, @regexp;
1832             }
1833             else {
1834 0         0 push @multipleoctet, @regexp;
1835             }
1836             }
1837              
1838 182         444 $i += 2;
1839             }
1840              
1841             # with /i modifier
1842             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1843 493 100       693 if ($modifier =~ /i/oxms) {
1844 24         49 my $uc = Elatin4::uc($char[$i]);
1845 24         48 my $fc = Elatin4::fc($char[$i]);
1846 24 100       40 if ($uc ne $fc) {
1847 12 50       25 if (CORE::length($fc) == 1) {
1848 12         18 push @singleoctet, $uc, $fc;
1849             }
1850             else {
1851 0         0 push @singleoctet, $uc;
1852 0         0 push @multipleoctet, $fc;
1853             }
1854             }
1855             else {
1856 12         23 push @singleoctet, $char[$i];
1857             }
1858             }
1859             else {
1860 469         602 push @singleoctet, $char[$i];
1861             }
1862 493         813 $i += 1;
1863             }
1864              
1865             # single character of single octet code
1866             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1867 0         0 push @singleoctet, "\t", "\x20";
1868 0         0 $i += 1;
1869             }
1870             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1871 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1872 0         0 $i += 1;
1873             }
1874             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1875 2         5 push @singleoctet, $char[$i];
1876 2         5 $i += 1;
1877             }
1878              
1879             # single character of multiple-octet code
1880             else {
1881 84         134 push @multipleoctet, $char[$i];
1882 84         302 $i += 1;
1883             }
1884             }
1885              
1886             # quote metachar
1887 358         717 for (@singleoctet) {
1888 689 50       3668 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1889 0         0 $_ = '-';
1890             }
1891             elsif (/\A \n \z/oxms) {
1892 8         22 $_ = '\n';
1893             }
1894             elsif (/\A \r \z/oxms) {
1895 8         21 $_ = '\r';
1896             }
1897             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1898 60         191 $_ = sprintf('\x%02X', CORE::ord $1);
1899             }
1900             elsif (/\A [\x00-\xFF] \z/oxms) {
1901 429         564 $_ = quotemeta $_;
1902             }
1903             }
1904              
1905             # return character list
1906 358         1122 return \@singleoctet, \@multipleoctet;
1907             }
1908              
1909             #
1910             # Latin-4 octal escape sequence
1911             #
1912             sub octchr {
1913 5     5 0 11 my($octdigit) = @_;
1914              
1915 5         6 my @binary = ();
1916 5         16 for my $octal (split(//,$octdigit)) {
1917             push @binary, {
1918             '0' => '000',
1919             '1' => '001',
1920             '2' => '010',
1921             '3' => '011',
1922             '4' => '100',
1923             '5' => '101',
1924             '6' => '110',
1925             '7' => '111',
1926 50         149 }->{$octal};
1927             }
1928 5         16 my $binary = join '', @binary;
1929              
1930             my $octchr = {
1931             # 1234567
1932             1 => pack('B*', "0000000$binary"),
1933             2 => pack('B*', "000000$binary"),
1934             3 => pack('B*', "00000$binary"),
1935             4 => pack('B*', "0000$binary"),
1936             5 => pack('B*', "000$binary"),
1937             6 => pack('B*', "00$binary"),
1938             7 => pack('B*', "0$binary"),
1939             0 => pack('B*', "$binary"),
1940              
1941 5         68 }->{CORE::length($binary) % 8};
1942              
1943 5         19 return $octchr;
1944             }
1945              
1946             #
1947             # Latin-4 hexadecimal escape sequence
1948             #
1949             sub hexchr {
1950 5     5 0 15 my($hexdigit) = @_;
1951              
1952             my $hexchr = {
1953             1 => pack('H*', "0$hexdigit"),
1954             0 => pack('H*', "$hexdigit"),
1955              
1956 5         64 }->{CORE::length($_[0]) % 2};
1957              
1958 5         21 return $hexchr;
1959             }
1960              
1961             #
1962             # Latin-4 open character list for qr
1963             #
1964             sub charlist_qr {
1965              
1966 314     314 0 610 my $modifier = pop @_;
1967 314         809 my @char = @_;
1968              
1969 314         840 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1970 314         680 my @singleoctet = @$singleoctet;
1971 314         476 my @multipleoctet = @$multipleoctet;
1972              
1973             # return character list
1974 314 100       757 if (scalar(@singleoctet) >= 1) {
1975              
1976             # with /i modifier
1977 236 100       529 if ($modifier =~ m/i/oxms) {
1978 22         34 my %singleoctet_ignorecase = ();
1979 22         32 for (@singleoctet) {
1980 46   100     225 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1981 46         127 for my $ord (hex($1) .. hex($2)) {
1982 66         83 my $char = CORE::chr($ord);
1983 66         79 my $uc = Elatin4::uc($char);
1984 66         92 my $fc = Elatin4::fc($char);
1985 66 100       99 if ($uc eq $fc) {
1986 12         93 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1987             }
1988             else {
1989 54 50       71 if (CORE::length($fc) == 1) {
1990 54         98 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1991 54         199 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1992             }
1993             else {
1994 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1995 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1996             }
1997             }
1998             }
1999             }
2000 46 50       95 if ($_ ne '') {
2001 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2002             }
2003             }
2004 22         23 my $i = 0;
2005 22         28 my @singleoctet_ignorecase = ();
2006 22         34 for my $ord (0 .. 255) {
2007 5632 100       5105 if (exists $singleoctet_ignorecase{$ord}) {
2008 96         71 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         172  
2009             }
2010             else {
2011 5536         3718 $i++;
2012             }
2013             }
2014 22         46 @singleoctet = ();
2015 22         57 for my $range (@singleoctet_ignorecase) {
2016 3648 100       5537 if (ref $range) {
2017 56 100       39 if (scalar(@{$range}) == 1) {
  56 50       88  
2018 36         33 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         140  
2019             }
2020 20         24 elsif (scalar(@{$range}) == 2) {
2021 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2022             }
2023             else {
2024 20         14 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         21  
  20         80  
2025             }
2026             }
2027             }
2028             }
2029              
2030 236         352 my $not_anchor = '';
2031              
2032 236         688 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2033             }
2034 314 100       657 if (scalar(@multipleoctet) >= 2) {
2035 6         49 return '(?:' . join('|', @multipleoctet) . ')';
2036             }
2037             else {
2038 308         1379 return $multipleoctet[0];
2039             }
2040             }
2041              
2042             #
2043             # Latin-4 open character list for not qr
2044             #
2045             sub charlist_not_qr {
2046              
2047 44     44 0 81 my $modifier = pop @_;
2048 44         109 my @char = @_;
2049              
2050 44         151 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2051 44         115 my @singleoctet = @$singleoctet;
2052 44         69 my @multipleoctet = @$multipleoctet;
2053              
2054             # with /i modifier
2055 44 100       124 if ($modifier =~ m/i/oxms) {
2056 10         19 my %singleoctet_ignorecase = ();
2057 10         18 for (@singleoctet) {
2058 10   66     61 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2059 10         50 for my $ord (hex($1) .. hex($2)) {
2060 30         44 my $char = CORE::chr($ord);
2061 30         47 my $uc = Elatin4::uc($char);
2062 30         63 my $fc = Elatin4::fc($char);
2063 30 50       62 if ($uc eq $fc) {
2064 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2065             }
2066             else {
2067 30 50       48 if (CORE::length($fc) == 1) {
2068 30         93 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2069 30         143 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2070             }
2071             else {
2072 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2073 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2074             }
2075             }
2076             }
2077             }
2078 10 50       30 if ($_ ne '') {
2079 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2080             }
2081             }
2082 10         11 my $i = 0;
2083 10         15 my @singleoctet_ignorecase = ();
2084 10         21 for my $ord (0 .. 255) {
2085 2560 100       3709 if (exists $singleoctet_ignorecase{$ord}) {
2086 60         47 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         134  
2087             }
2088             else {
2089 2500         2301 $i++;
2090             }
2091             }
2092 10         27 @singleoctet = ();
2093 10         29 for my $range (@singleoctet_ignorecase) {
2094 960 100       1975 if (ref $range) {
2095 20 50       14 if (scalar(@{$range}) == 1) {
  20 50       45  
2096 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2097             }
2098 20         38 elsif (scalar(@{$range}) == 2) {
2099 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2100             }
2101             else {
2102 20         21 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         27  
  20         126  
2103             }
2104             }
2105             }
2106             }
2107              
2108             # return character list
2109 44 50       114 if (scalar(@multipleoctet) >= 1) {
2110 0 0       0 if (scalar(@singleoctet) >= 1) {
2111              
2112             # any character other than multiple-octet and single octet character class
2113 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2114             }
2115             else {
2116              
2117             # any character other than multiple-octet character class
2118 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2119             }
2120             }
2121             else {
2122 44 50       96 if (scalar(@singleoctet) >= 1) {
2123              
2124             # any character other than single octet character class
2125 44         311 return '(?:[^' . join('', @singleoctet) . '])';
2126             }
2127             else {
2128              
2129             # any character
2130 0         0 return "(?:$your_char)";
2131             }
2132             }
2133             }
2134              
2135             #
2136             # open file in read mode
2137             #
2138             sub _open_r {
2139 400     400   2574 my(undef,$file) = @_;
2140 400         1243 $file =~ s#\A (\s) #./$1#oxms;
2141 400   33     38054 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2142             open($_[0],"< $file\0");
2143             }
2144              
2145             #
2146             # open file in write mode
2147             #
2148             sub _open_w {
2149 0     0   0 my(undef,$file) = @_;
2150 0         0 $file =~ s#\A (\s) #./$1#oxms;
2151 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2152             open($_[0],"> $file\0");
2153             }
2154              
2155             #
2156             # open file in append mode
2157             #
2158             sub _open_a {
2159 0     0   0 my(undef,$file) = @_;
2160 0         0 $file =~ s#\A (\s) #./$1#oxms;
2161 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2162             open($_[0],">> $file\0");
2163             }
2164              
2165             #
2166             # safe system
2167             #
2168             sub _systemx {
2169              
2170             # P.707 29.2.33. exec
2171             # in Chapter 29: Functions
2172             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2173             #
2174             # Be aware that in older releases of Perl, exec (and system) did not flush
2175             # your output buffer, so you needed to enable command buffering by setting $|
2176             # on one or more filehandles to avoid lost output in the case of exec, or
2177             # misordererd output in the case of system. This situation was largely remedied
2178             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2179              
2180             # P.855 exec
2181             # in Chapter 27: Functions
2182             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2183             #
2184             # In very old release of Perl (before v5.6), exec (and system) did not flush
2185             # your output buffer, so you needed to enable command buffering by setting $|
2186             # on one or more filehandles to avoid lost output with exec or misordered
2187             # output with system.
2188              
2189 200     200   776 $| = 1;
2190              
2191             # P.565 23.1.2. Cleaning Up Your Environment
2192             # in Chapter 23: Security
2193             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2194              
2195             # P.656 Cleaning Up Your Environment
2196             # in Chapter 20: Security
2197             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2198              
2199             # local $ENV{'PATH'} = '.';
2200 200         1957 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2201              
2202             # P.707 29.2.33. exec
2203             # in Chapter 29: Functions
2204             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2205             #
2206             # As we mentioned earlier, exec treats a discrete list of arguments as an
2207             # indication that it should bypass shell processing. However, there is one
2208             # place where you might still get tripped up. The exec call (and system, too)
2209             # will not distinguish between a single scalar argument and an array containing
2210             # only one element.
2211             #
2212             # @args = ("echo surprise"); # just one element in list
2213             # exec @args # still subject to shell escapes
2214             # or die "exec: $!"; # because @args == 1
2215             #
2216             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2217             # first argument as the pathname, which forces the rest of the arguments to be
2218             # interpreted as a list, even if there is only one of them:
2219             #
2220             # exec { $args[0] } @args # safe even with one-argument list
2221             # or die "can't exec @args: $!";
2222              
2223             # P.855 exec
2224             # in Chapter 27: Functions
2225             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2226             #
2227             # As we mentioned earlier, exec treats a discrete list of arguments as a
2228             # directive to bypass shell processing. However, there is one place where
2229             # you might still get tripped up. The exec call (and system, too) cannot
2230             # distinguish between a single scalar argument and an array containing
2231             # only one element.
2232             #
2233             # @args = ("echo surprise"); # just one element in list
2234             # exec @args # still subject to shell escapes
2235             # || die "exec: $!"; # because @args == 1
2236             #
2237             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2238             # argument as the pathname, which forces the rest of the arguments to be
2239             # interpreted as a list, even if there is only one of them:
2240             #
2241             # exec { $args[0] } @args # safe even with one-argument list
2242             # || die "can't exec @args: $!";
2243              
2244 200         367 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         17473546  
2245             }
2246              
2247             #
2248             # Latin-4 order to character (with parameter)
2249             #
2250             sub Elatin4::chr(;$) {
2251              
2252 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2253              
2254 0 0       0 if ($c == 0x00) {
2255 0         0 return "\x00";
2256             }
2257             else {
2258 0         0 my @chr = ();
2259 0         0 while ($c > 0) {
2260 0         0 unshift @chr, ($c % 0x100);
2261 0         0 $c = int($c / 0x100);
2262             }
2263 0         0 return pack 'C*', @chr;
2264             }
2265             }
2266              
2267             #
2268             # Latin-4 order to character (without parameter)
2269             #
2270             sub Elatin4::chr_() {
2271              
2272 0     0 0 0 my $c = $_;
2273              
2274 0 0       0 if ($c == 0x00) {
2275 0         0 return "\x00";
2276             }
2277             else {
2278 0         0 my @chr = ();
2279 0         0 while ($c > 0) {
2280 0         0 unshift @chr, ($c % 0x100);
2281 0         0 $c = int($c / 0x100);
2282             }
2283 0         0 return pack 'C*', @chr;
2284             }
2285             }
2286              
2287             #
2288             # Latin-4 path globbing (with parameter)
2289             #
2290             sub Elatin4::glob($) {
2291              
2292 0 0   0 0 0 if (wantarray) {
2293 0         0 my @glob = _DOS_like_glob(@_);
2294 0         0 for my $glob (@glob) {
2295 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2296             }
2297 0         0 return @glob;
2298             }
2299             else {
2300 0         0 my $glob = _DOS_like_glob(@_);
2301 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2302 0         0 return $glob;
2303             }
2304             }
2305              
2306             #
2307             # Latin-4 path globbing (without parameter)
2308             #
2309             sub Elatin4::glob_() {
2310              
2311 0 0   0 0 0 if (wantarray) {
2312 0         0 my @glob = _DOS_like_glob();
2313 0         0 for my $glob (@glob) {
2314 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2315             }
2316 0         0 return @glob;
2317             }
2318             else {
2319 0         0 my $glob = _DOS_like_glob();
2320 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2321 0         0 return $glob;
2322             }
2323             }
2324              
2325             #
2326             # Latin-4 path globbing via File::DosGlob 1.10
2327             #
2328             # Often I confuse "_dosglob" and "_doglob".
2329             # So, I renamed "_dosglob" to "_DOS_like_glob".
2330             #
2331             my %iter;
2332             my %entries;
2333             sub _DOS_like_glob {
2334              
2335             # context (keyed by second cxix argument provided by core)
2336 0     0   0 my($expr,$cxix) = @_;
2337              
2338             # glob without args defaults to $_
2339 0 0       0 $expr = $_ if not defined $expr;
2340              
2341             # represents the current user's home directory
2342             #
2343             # 7.3. Expanding Tildes in Filenames
2344             # in Chapter 7. File Access
2345             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2346             #
2347             # and File::HomeDir, File::HomeDir::Windows module
2348              
2349             # DOS-like system
2350 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2351 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2352 0         0 { my_home_MSWin32() }oxmse;
2353             }
2354              
2355             # UNIX-like system
2356             else {
2357 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2358 0 0 0     0 { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2359             }
2360              
2361             # assume global context if not provided one
2362 0 0       0 $cxix = '_G_' if not defined $cxix;
2363 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2364              
2365             # if we're just beginning, do it all first
2366 0 0       0 if ($iter{$cxix} == 0) {
2367 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2368             }
2369              
2370             # chuck it all out, quick or slow
2371 0 0       0 if (wantarray) {
2372 0         0 delete $iter{$cxix};
2373 0         0 return @{delete $entries{$cxix}};
  0         0  
2374             }
2375             else {
2376 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2377 0         0 return shift @{$entries{$cxix}};
  0         0  
2378             }
2379             else {
2380             # return undef for EOL
2381 0         0 delete $iter{$cxix};
2382 0         0 delete $entries{$cxix};
2383 0         0 return undef;
2384             }
2385             }
2386             }
2387              
2388             #
2389             # Latin-4 path globbing subroutine
2390             #
2391             sub _do_glob {
2392              
2393 0     0   0 my($cond,@expr) = @_;
2394 0         0 my @glob = ();
2395 0         0 my $fix_drive_relative_paths = 0;
2396              
2397             OUTER:
2398 0         0 for my $expr (@expr) {
2399 0 0       0 next OUTER if not defined $expr;
2400 0 0       0 next OUTER if $expr eq '';
2401              
2402 0         0 my @matched = ();
2403 0         0 my @globdir = ();
2404 0         0 my $head = '.';
2405 0         0 my $pathsep = '/';
2406 0         0 my $tail;
2407              
2408             # if argument is within quotes strip em and do no globbing
2409 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2410 0         0 $expr = $1;
2411 0 0       0 if ($cond eq 'd') {
2412 0 0       0 if (-d $expr) {
2413 0         0 push @glob, $expr;
2414             }
2415             }
2416             else {
2417 0 0       0 if (-e $expr) {
2418 0         0 push @glob, $expr;
2419             }
2420             }
2421 0         0 next OUTER;
2422             }
2423              
2424             # wildcards with a drive prefix such as h:*.pm must be changed
2425             # to h:./*.pm to expand correctly
2426 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2427 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2428 0         0 $fix_drive_relative_paths = 1;
2429             }
2430             }
2431              
2432 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2433 0 0       0 if ($tail eq '') {
2434 0         0 push @glob, $expr;
2435 0         0 next OUTER;
2436             }
2437 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2438 0 0       0 if (@globdir = _do_glob('d', $head)) {
2439 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2440 0         0 next OUTER;
2441             }
2442             }
2443 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2444 0         0 $head .= $pathsep;
2445             }
2446 0         0 $expr = $tail;
2447             }
2448              
2449             # If file component has no wildcards, we can avoid opendir
2450 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2451 0 0       0 if ($head eq '.') {
2452 0         0 $head = '';
2453             }
2454 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2455 0         0 $head .= $pathsep;
2456             }
2457 0         0 $head .= $expr;
2458 0 0       0 if ($cond eq 'd') {
2459 0 0       0 if (-d $head) {
2460 0         0 push @glob, $head;
2461             }
2462             }
2463             else {
2464 0 0       0 if (-e $head) {
2465 0         0 push @glob, $head;
2466             }
2467             }
2468 0         0 next OUTER;
2469             }
2470 0 0       0 opendir(*DIR, $head) or next OUTER;
2471 0         0 my @leaf = readdir DIR;
2472 0         0 closedir DIR;
2473              
2474 0 0       0 if ($head eq '.') {
2475 0         0 $head = '';
2476             }
2477 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2478 0         0 $head .= $pathsep;
2479             }
2480              
2481 0         0 my $pattern = '';
2482 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2483 0         0 my $char = $1;
2484              
2485             # 6.9. Matching Shell Globs as Regular Expressions
2486             # in Chapter 6. Pattern Matching
2487             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2488             # (and so on)
2489              
2490 0 0       0 if ($char eq '*') {
    0          
    0          
2491 0         0 $pattern .= "(?:$your_char)*",
2492             }
2493             elsif ($char eq '?') {
2494 0         0 $pattern .= "(?:$your_char)?", # DOS style
2495             # $pattern .= "(?:$your_char)", # UNIX style
2496             }
2497             elsif ((my $fc = Elatin4::fc($char)) ne $char) {
2498 0         0 $pattern .= $fc;
2499             }
2500             else {
2501 0         0 $pattern .= quotemeta $char;
2502             }
2503             }
2504 0     0   0 my $matchsub = sub { Elatin4::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2505              
2506             # if ($@) {
2507             # print STDERR "$0: $@\n";
2508             # next OUTER;
2509             # }
2510              
2511             INNER:
2512 0         0 for my $leaf (@leaf) {
2513 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2514 0         0 next INNER;
2515             }
2516 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2517 0         0 next INNER;
2518             }
2519              
2520 0 0       0 if (&$matchsub($leaf)) {
2521 0         0 push @matched, "$head$leaf";
2522 0         0 next INNER;
2523             }
2524              
2525             # [DOS compatibility special case]
2526             # Failed, add a trailing dot and try again, but only...
2527              
2528 0 0 0     0 if (Elatin4::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2529             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2530             Elatin4::index($pattern,'\\.') != -1 # pattern has a dot.
2531             ) {
2532 0 0       0 if (&$matchsub("$leaf.")) {
2533 0         0 push @matched, "$head$leaf";
2534 0         0 next INNER;
2535             }
2536             }
2537             }
2538 0 0       0 if (@matched) {
2539 0         0 push @glob, @matched;
2540             }
2541             }
2542 0 0       0 if ($fix_drive_relative_paths) {
2543 0         0 for my $glob (@glob) {
2544 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2545             }
2546             }
2547 0         0 return @glob;
2548             }
2549              
2550             #
2551             # Latin-4 parse line
2552             #
2553             sub _parse_line {
2554              
2555 0     0   0 my($line) = @_;
2556              
2557 0         0 $line .= ' ';
2558 0         0 my @piece = ();
2559 0         0 while ($line =~ /
2560             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2561             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2562             /oxmsg
2563             ) {
2564 0 0       0 push @piece, defined($1) ? $1 : $2;
2565             }
2566 0         0 return @piece;
2567             }
2568              
2569             #
2570             # Latin-4 parse path
2571             #
2572             sub _parse_path {
2573              
2574 0     0   0 my($path,$pathsep) = @_;
2575              
2576 0         0 $path .= '/';
2577 0         0 my @subpath = ();
2578 0         0 while ($path =~ /
2579             ((?: [^\/\\] )+?) [\/\\]
2580             /oxmsg
2581             ) {
2582 0         0 push @subpath, $1;
2583             }
2584              
2585 0         0 my $tail = pop @subpath;
2586 0         0 my $head = join $pathsep, @subpath;
2587 0         0 return $head, $tail;
2588             }
2589              
2590             #
2591             # via File::HomeDir::Windows 1.00
2592             #
2593             sub my_home_MSWin32 {
2594              
2595             # A lot of unix people and unix-derived tools rely on
2596             # the ability to overload HOME. We will support it too
2597             # so that they can replace raw HOME calls with File::HomeDir.
2598 0 0 0 0 0 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2599 0         0 return $ENV{'HOME'};
2600             }
2601              
2602             # Do we have a user profile?
2603             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2604 0         0 return $ENV{'USERPROFILE'};
2605             }
2606              
2607             # Some Windows use something like $ENV{'HOME'}
2608             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2609 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2610             }
2611              
2612 0         0 return undef;
2613             }
2614              
2615             #
2616             # via File::HomeDir::Unix 1.00
2617             #
2618             sub my_home {
2619 0     0 0 0 my $home;
2620              
2621 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2622 0         0 $home = $ENV{'HOME'};
2623             }
2624              
2625             # This is from the original code, but I'm guessing
2626             # it means "login directory" and exists on some Unixes.
2627             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2628 0         0 $home = $ENV{'LOGDIR'};
2629             }
2630              
2631             ### More-desperate methods
2632              
2633             # Light desperation on any (Unixish) platform
2634             else {
2635 0         0 $home = CORE::eval q{ (getpwuid($<))[7] };
2636             }
2637              
2638             # On Unix in general, a non-existant home means "no home"
2639             # For example, "nobody"-like users might use /nonexistant
2640 0 0 0     0 if (defined $home and ! -d($home)) {
2641 0         0 $home = undef;
2642             }
2643 0         0 return $home;
2644             }
2645              
2646             #
2647             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2648             #
2649             sub Elatin4::PREMATCH {
2650 0     0 0 0 return $`;
2651             }
2652              
2653             #
2654             # ${^MATCH}, $MATCH, $& the string that matched
2655             #
2656             sub Elatin4::MATCH {
2657 0     0 0 0 return $&;
2658             }
2659              
2660             #
2661             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2662             #
2663             sub Elatin4::POSTMATCH {
2664 0     0 0 0 return $';
2665             }
2666              
2667             #
2668             # Latin-4 character to order (with parameter)
2669             #
2670             sub Latin4::ord(;$) {
2671              
2672 0 0   0 1 0 local $_ = shift if @_;
2673              
2674 0 0       0 if (/\A ($q_char) /oxms) {
2675 0         0 my @ord = unpack 'C*', $1;
2676 0         0 my $ord = 0;
2677 0         0 while (my $o = shift @ord) {
2678 0         0 $ord = $ord * 0x100 + $o;
2679             }
2680 0         0 return $ord;
2681             }
2682             else {
2683 0         0 return CORE::ord $_;
2684             }
2685             }
2686              
2687             #
2688             # Latin-4 character to order (without parameter)
2689             #
2690             sub Latin4::ord_() {
2691              
2692 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2693 0         0 my @ord = unpack 'C*', $1;
2694 0         0 my $ord = 0;
2695 0         0 while (my $o = shift @ord) {
2696 0         0 $ord = $ord * 0x100 + $o;
2697             }
2698 0         0 return $ord;
2699             }
2700             else {
2701 0         0 return CORE::ord $_;
2702             }
2703             }
2704              
2705             #
2706             # Latin-4 reverse
2707             #
2708             sub Latin4::reverse(@) {
2709              
2710 0 0   0 0 0 if (wantarray) {
2711 0         0 return CORE::reverse @_;
2712             }
2713             else {
2714              
2715             # One of us once cornered Larry in an elevator and asked him what
2716             # problem he was solving with this, but he looked as far off into
2717             # the distance as he could in an elevator and said, "It seemed like
2718             # a good idea at the time."
2719              
2720 0         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2721             }
2722             }
2723              
2724             #
2725             # Latin-4 getc (with parameter, without parameter)
2726             #
2727             sub Latin4::getc(;*@) {
2728              
2729 0     0 0 0 my($package) = caller;
2730 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2731 0 0 0     0 croak 'Too many arguments for Latin4::getc' if @_ and not wantarray;
2732              
2733 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2734 0         0 my $getc = '';
2735 0         0 for my $length ($length[0] .. $length[-1]) {
2736 0         0 $getc .= CORE::getc($fh);
2737 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2738 0 0       0 if ($getc =~ /\A ${Elatin4::dot_s} \z/oxms) {
2739 0 0       0 return wantarray ? ($getc,@_) : $getc;
2740             }
2741             }
2742             }
2743 0 0       0 return wantarray ? ($getc,@_) : $getc;
2744             }
2745              
2746             #
2747             # Latin-4 length by character
2748             #
2749             sub Latin4::length(;$) {
2750              
2751 0 0   0 1 0 local $_ = shift if @_;
2752              
2753 0         0 local @_ = /\G ($q_char) /oxmsg;
2754 0         0 return scalar @_;
2755             }
2756              
2757             #
2758             # Latin-4 substr by character
2759             #
2760             BEGIN {
2761              
2762             # P.232 The lvalue Attribute
2763             # in Chapter 6: Subroutines
2764             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2765              
2766             # P.336 The lvalue Attribute
2767             # in Chapter 7: Subroutines
2768             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2769              
2770             # P.144 8.4 Lvalue subroutines
2771             # in Chapter 8: perlsub: Perl subroutines
2772             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2773              
2774 200 50 0 200 1 120986 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  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  
2775             # vv----------------------*******
2776             sub Latin4::substr($$;$$) %s {
2777              
2778             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2779              
2780             # If the substring is beyond either end of the string, substr() returns the undefined
2781             # value and produces a warning. When used as an lvalue, specifying a substring that
2782             # is entirely outside the string raises an exception.
2783             # http://perldoc.perl.org/functions/substr.html
2784              
2785             # A return with no argument returns the scalar value undef in scalar context,
2786             # an empty list () in list context, and (naturally) nothing at all in void
2787             # context.
2788              
2789             my $offset = $_[1];
2790             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2791             return;
2792             }
2793              
2794             # substr($string,$offset,$length,$replacement)
2795             if (@_ == 4) {
2796             my(undef,undef,$length,$replacement) = @_;
2797             my $substr = join '', splice(@char, $offset, $length, $replacement);
2798             $_[0] = join '', @char;
2799              
2800             # return $substr; this doesn't work, don't say "return"
2801             $substr;
2802             }
2803              
2804             # substr($string,$offset,$length)
2805             elsif (@_ == 3) {
2806             my(undef,undef,$length) = @_;
2807             my $octet_offset = 0;
2808             my $octet_length = 0;
2809             if ($offset == 0) {
2810             $octet_offset = 0;
2811             }
2812             elsif ($offset > 0) {
2813             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2814             }
2815             else {
2816             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2817             }
2818             if ($length == 0) {
2819             $octet_length = 0;
2820             }
2821             elsif ($length > 0) {
2822             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2823             }
2824             else {
2825             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2826             }
2827             CORE::substr($_[0], $octet_offset, $octet_length);
2828             }
2829              
2830             # substr($string,$offset)
2831             else {
2832             my $octet_offset = 0;
2833             if ($offset == 0) {
2834             $octet_offset = 0;
2835             }
2836             elsif ($offset > 0) {
2837             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2838             }
2839             else {
2840             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2841             }
2842             CORE::substr($_[0], $octet_offset);
2843             }
2844             }
2845             END
2846             }
2847              
2848             #
2849             # Latin-4 index by character
2850             #
2851             sub Latin4::index($$;$) {
2852              
2853 0     0 1 0 my $index;
2854 0 0       0 if (@_ == 3) {
2855 0         0 $index = Elatin4::index($_[0], $_[1], CORE::length(Latin4::substr($_[0], 0, $_[2])));
2856             }
2857             else {
2858 0         0 $index = Elatin4::index($_[0], $_[1]);
2859             }
2860              
2861 0 0       0 if ($index == -1) {
2862 0         0 return -1;
2863             }
2864             else {
2865 0         0 return Latin4::length(CORE::substr $_[0], 0, $index);
2866             }
2867             }
2868              
2869             #
2870             # Latin-4 rindex by character
2871             #
2872             sub Latin4::rindex($$;$) {
2873              
2874 0     0 1 0 my $rindex;
2875 0 0       0 if (@_ == 3) {
2876 0         0 $rindex = Elatin4::rindex($_[0], $_[1], CORE::length(Latin4::substr($_[0], 0, $_[2])));
2877             }
2878             else {
2879 0         0 $rindex = Elatin4::rindex($_[0], $_[1]);
2880             }
2881              
2882 0 0       0 if ($rindex == -1) {
2883 0         0 return -1;
2884             }
2885             else {
2886 0         0 return Latin4::length(CORE::substr $_[0], 0, $rindex);
2887             }
2888             }
2889              
2890             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2891             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2892 200     200   14520 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1651  
  200         387  
  200         13242  
2893              
2894             # ord() to ord() or Latin4::ord()
2895 200     200   11970 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1036  
  200         377  
  200         10626  
2896              
2897             # ord to ord or Latin4::ord_
2898 200     200   11801 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   977  
  200         357  
  200         11145  
2899              
2900             # reverse to reverse or Latin4::reverse
2901 200     200   11661 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   1024  
  200         339  
  200         10971  
2902              
2903             # getc to getc or Latin4::getc
2904 200     200   10721 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   940  
  200         341  
  200         14969  
2905              
2906             # P.1023 Appendix W.9 Multibyte Anchoring
2907             # of ISBN 1-56592-224-7 CJKV Information Processing
2908              
2909             my $anchor = '';
2910              
2911 200     200   11242 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   938  
  200         336  
  200         8780194  
2912              
2913             # regexp of nested parens in qqXX
2914              
2915             # P.340 Matching Nested Constructs with Embedded Code
2916             # in Chapter 7: Perl
2917             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2918              
2919             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2920             [^\\()] |
2921             \( (?{$nest++}) |
2922             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2923             \\ [^c] |
2924             \\c[\x40-\x5F] |
2925             [\x00-\xFF]
2926             }xms;
2927              
2928             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2929             [^\\{}] |
2930             \{ (?{$nest++}) |
2931             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2932             \\ [^c] |
2933             \\c[\x40-\x5F] |
2934             [\x00-\xFF]
2935             }xms;
2936              
2937             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2938             [^\\\[\]] |
2939             \[ (?{$nest++}) |
2940             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2941             \\ [^c] |
2942             \\c[\x40-\x5F] |
2943             [\x00-\xFF]
2944             }xms;
2945              
2946             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2947             [^\\<>] |
2948             \< (?{$nest++}) |
2949             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2950             \\ [^c] |
2951             \\c[\x40-\x5F] |
2952             [\x00-\xFF]
2953             }xms;
2954              
2955             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2956             (?: ::)? (?:
2957             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2958             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2959             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2960             ))
2961             }xms;
2962              
2963             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2964             (?: ::)? (?:
2965             (?>[0-9]+) |
2966             [^a-zA-Z_0-9\[\]] |
2967             ^[A-Z] |
2968             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2969             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2970             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2971             ))
2972             }xms;
2973              
2974             my $qq_substr = qr{(?> Char::substr | Latin4::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2975             }xms;
2976              
2977             # regexp of nested parens in qXX
2978             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2979             [^()] |
2980             \( (?{$nest++}) |
2981             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2982             [\x00-\xFF]
2983             }xms;
2984              
2985             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2986             [^\{\}] |
2987             \{ (?{$nest++}) |
2988             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2989             [\x00-\xFF]
2990             }xms;
2991              
2992             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2993             [^\[\]] |
2994             \[ (?{$nest++}) |
2995             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2996             [\x00-\xFF]
2997             }xms;
2998              
2999             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3000             [^<>] |
3001             \< (?{$nest++}) |
3002             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3003             [\x00-\xFF]
3004             }xms;
3005              
3006             my $matched = '';
3007             my $s_matched = '';
3008              
3009             my $tr_variable = ''; # variable of tr///
3010             my $sub_variable = ''; # variable of s///
3011             my $bind_operator = ''; # =~ or !~
3012              
3013             my @heredoc = (); # here document
3014             my @heredoc_delimiter = ();
3015             my $here_script = ''; # here script
3016              
3017             #
3018             # escape Latin-4 script
3019             #
3020             sub Latin4::escape(;$) {
3021 200 50   200 0 865 local($_) = $_[0] if @_;
3022              
3023             # P.359 The Study Function
3024             # in Chapter 7: Perl
3025             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3026              
3027 200         354 study $_; # Yes, I studied study yesterday.
3028              
3029             # while all script
3030              
3031             # 6.14. Matching from Where the Last Pattern Left Off
3032             # in Chapter 6. Pattern Matching
3033             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3034             # (and so on)
3035              
3036             # one member of Tag-team
3037             #
3038             # P.128 Start of match (or end of previous match): \G
3039             # P.130 Advanced Use of \G with Perl
3040             # in Chapter 3: Overview of Regular Expression Features and Flavors
3041             # P.255 Use leading anchors
3042             # P.256 Expose ^ and \G at the front expressions
3043             # in Chapter 6: Crafting an Efficient Expression
3044             # P.315 "Tag-team" matching with /gc
3045             # in Chapter 7: Perl
3046             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3047              
3048 200         336 my $e_script = '';
3049 200         854 while (not /\G \z/oxgc) { # member
3050 71994         91430 $e_script .= Latin4::escape_token();
3051             }
3052              
3053 200         2317 return $e_script;
3054             }
3055              
3056             #
3057             # escape Latin-4 token of script
3058             #
3059             sub Latin4::escape_token {
3060              
3061             # \n output here document
3062              
3063 71994     71994 0 62333 my $ignore_modules = join('|', qw(
3064             utf8
3065             bytes
3066             charnames
3067             I18N::Japanese
3068             I18N::Collate
3069             I18N::JExt
3070             File::DosGlob
3071             Wild
3072             Wildcard
3073             Japanese
3074             ));
3075              
3076             # another member of Tag-team
3077             #
3078             # P.315 "Tag-team" matching with /gc
3079             # in Chapter 7: Perl
3080             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3081              
3082 71994 100 100     4012565 if (/\G ( \n ) /oxgc) { # another member (and so on)
    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          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3083 12085         11044 my $heredoc = '';
3084 12085 100       21559 if (scalar(@heredoc_delimiter) >= 1) {
3085 150         174 $slash = 'm//';
3086              
3087 150         285 $heredoc = join '', @heredoc;
3088 150         265 @heredoc = ();
3089              
3090             # skip here document
3091 150         265 for my $heredoc_delimiter (@heredoc_delimiter) {
3092 150         1115 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3093             }
3094 150         308 @heredoc_delimiter = ();
3095              
3096 150         191 $here_script = '';
3097             }
3098 12085         36276 return "\n" . $heredoc;
3099             }
3100              
3101             # ignore space, comment
3102 17322         53398 elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3103              
3104             # if (, elsif (, unless (, while (, until (, given (, and when (
3105              
3106             # given, when
3107              
3108             # P.225 The given Statement
3109             # in Chapter 15: Smart Matching and given-when
3110             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3111              
3112             # P.133 The given Statement
3113             # in Chapter 4: Statements and Declarations
3114             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3115              
3116             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3117 1373         1731 $slash = 'm//';
3118 1373         4569 return $1;
3119             }
3120              
3121             # scalar variable ($scalar = ...) =~ tr///;
3122             # scalar variable ($scalar = ...) =~ s///;
3123              
3124             # state
3125              
3126             # P.68 Persistent, Private Variables
3127             # in Chapter 4: Subroutines
3128             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3129              
3130             # P.160 Persistent Lexically Scoped Variables: state
3131             # in Chapter 4: Statements and Declarations
3132             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3133              
3134             # (and so on)
3135              
3136             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3137 85         169 my $e_string = e_string($1);
3138              
3139 85 50       2139 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3140 0         0 $tr_variable = $e_string . e_string($1);
3141 0         0 $bind_operator = $2;
3142 0         0 $slash = 'm//';
3143 0         0 return '';
3144             }
3145             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3146 0         0 $sub_variable = $e_string . e_string($1);
3147 0         0 $bind_operator = $2;
3148 0         0 $slash = 'm//';
3149 0         0 return '';
3150             }
3151             else {
3152 85         111 $slash = 'div';
3153 85         312 return $e_string;
3154             }
3155             }
3156              
3157             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin4::PREMATCH()
3158             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3159 4         8 $slash = 'div';
3160 4         15 return q{Elatin4::PREMATCH()};
3161             }
3162              
3163             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin4::MATCH()
3164             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3165 28         46 $slash = 'div';
3166 28         93 return q{Elatin4::MATCH()};
3167             }
3168              
3169             # $', ${'} --> $', ${'}
3170             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3171 1         1 $slash = 'div';
3172 1         4 return $1;
3173             }
3174              
3175             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin4::POSTMATCH()
3176             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3177 3         7 $slash = 'div';
3178 3         9 return q{Elatin4::POSTMATCH()};
3179             }
3180              
3181             # scalar variable $scalar =~ tr///;
3182             # scalar variable $scalar =~ s///;
3183             # substr() =~ tr///;
3184             # substr() =~ s///;
3185             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3186 1604         3230 my $scalar = e_string($1);
3187              
3188 1604 100       6753 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3189 1         3 $tr_variable = $scalar;
3190 1         2 $bind_operator = $1;
3191 1         2 $slash = 'm//';
3192 1         3 return '';
3193             }
3194             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3195 61         117 $sub_variable = $scalar;
3196 61         126 $bind_operator = $1;
3197 61         129 $slash = 'm//';
3198 61         197 return '';
3199             }
3200             else {
3201 1542         1708 $slash = 'div';
3202 1542         4255 return $scalar;
3203             }
3204             }
3205              
3206             # end of statement
3207             elsif (/\G ( [,;] ) /oxgc) {
3208 4580         5144 $slash = 'm//';
3209              
3210             # clear tr/// variable
3211 4580         4240 $tr_variable = '';
3212              
3213             # clear s/// variable
3214 4580         3889 $sub_variable = '';
3215              
3216 4580         15263 $bind_operator = '';
3217              
3218 4580         16369 return $1;
3219             }
3220              
3221             # bareword
3222             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3223 0         0 return $1;
3224             }
3225              
3226             # $0 --> $0
3227             elsif (/\G ( \$ 0 ) /oxmsgc) {
3228 2         5 $slash = 'div';
3229 2         7 return $1;
3230             }
3231             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3232 0         0 $slash = 'div';
3233 0         0 return $1;
3234             }
3235              
3236             # $$ --> $$
3237             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3238 1         5 $slash = 'div';
3239 1         6 return $1;
3240             }
3241              
3242             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3243             # $1, $2, $3 --> $1, $2, $3 otherwise
3244             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3245 4         7 $slash = 'div';
3246 4         10 return e_capture($1);
3247             }
3248             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3249 0         0 $slash = 'div';
3250 0         0 return e_capture($1);
3251             }
3252              
3253             # $$foo[ ... ] --> $ $foo->[ ... ]
3254             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3255 0         0 $slash = 'div';
3256 0         0 return e_capture($1.'->'.$2);
3257             }
3258              
3259             # $$foo{ ... } --> $ $foo->{ ... }
3260             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3261 0         0 $slash = 'div';
3262 0         0 return e_capture($1.'->'.$2);
3263             }
3264              
3265             # $$foo
3266             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3267 0         0 $slash = 'div';
3268 0         0 return e_capture($1);
3269             }
3270              
3271             # ${ foo }
3272             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3273 0         0 $slash = 'div';
3274 0         0 return '${' . $1 . '}';
3275             }
3276              
3277             # ${ ... }
3278             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3279 0         0 $slash = 'div';
3280 0         0 return e_capture($1);
3281             }
3282              
3283             # variable or function
3284             # $ @ % & * $ #
3285             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) {
3286 42         66 $slash = 'div';
3287 42         229 return $1;
3288             }
3289             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3290             # $ @ # \ ' " / ? ( ) [ ] < >
3291             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3292 60         107 $slash = 'div';
3293 60         230 return $1;
3294             }
3295              
3296             # while ()
3297             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3298 0         0 return $1;
3299             }
3300              
3301             # while () --- glob
3302              
3303             # avoid "Error: Runtime exception" of perl version 5.005_03
3304              
3305             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3306 0         0 return 'while ($_ = Elatin4::glob("' . $1 . '"))';
3307             }
3308              
3309             # while (glob)
3310             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3311 0         0 return 'while ($_ = Elatin4::glob_)';
3312             }
3313              
3314             # while (glob(WILDCARD))
3315             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3316 0         0 return 'while ($_ = Elatin4::glob';
3317             }
3318              
3319             # doit if, doit unless, doit while, doit until, doit for, doit when
3320 241         507 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         1158  
3321              
3322             # subroutines of package Elatin4
3323 19         32 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         89  
3324 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3325 13         14 elsif (/\G \b Latin4::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         32  
3326 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3327 114         131 elsif (/\G \b Latin4::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin4::escape'; }
  114         353  
3328 2         4 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         7  
3329 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::chop'; }
  0         0  
3330 2         3 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
3331 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3332 0         0 elsif (/\G \b Latin4::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin4::index'; }
  0         0  
3333 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::index'; }
  0         0  
3334 2         3 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
3335 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3336 0         0 elsif (/\G \b Latin4::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin4::rindex'; }
  0         0  
3337 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::rindex'; }
  0         0  
3338 1         1 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin4::lc'; }
  1         5  
3339 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin4::lcfirst'; }
  0         0  
3340 1         2 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin4::uc'; }
  1         3  
3341 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin4::ucfirst'; }
  0         0  
3342 6         8 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin4::fc'; }
  6         27  
3343              
3344             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3345 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3346 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3347 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3348 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3349 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3350 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3351 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  
3352              
3353 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3354 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3355 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3356 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3357 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3358 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3359 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3360              
3361             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3362 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3363 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3364 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3365 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3366              
3367 2         3 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         8  
3368 2         6 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         9  
3369 36         62 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin4::chr'; }
  36         116  
3370 2         4 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         11  
3371 8         10 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         18  
3372 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin4::glob'; }
  0         0  
3373 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::lc_'; }
  0         0  
3374 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::lcfirst_'; }
  0         0  
3375 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::uc_'; }
  0         0  
3376 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::ucfirst_'; }
  0         0  
3377 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::fc_'; }
  0         0  
3378 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3379              
3380 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3381 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3382 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::chr_'; }
  0         0  
3383 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3384 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3385 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin4::glob_'; }
  0         0  
3386 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3387 8         24 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         49  
3388             # split
3389             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3390 87         165 $slash = 'm//';
3391              
3392 87         131 my $e = '';
3393 87         415 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3394 85         410 $e .= $1;
3395             }
3396              
3397             # end of split
3398 87 100       8360 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin4::split' . $e; }
  2 100       12  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3399              
3400             # split scalar value
3401 1         4 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin4::split' . $e . e_string($1); }
3402              
3403             # split literal space
3404 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin4::split' . $e . qq {qq$1 $2}; }
3405 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin4::split' . $e . qq{$1qq$2 $3}; }
3406 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin4::split' . $e . qq{$1qq$2 $3}; }
3407 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin4::split' . $e . qq{$1qq$2 $3}; }
3408 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin4::split' . $e . qq{$1qq$2 $3}; }
3409 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin4::split' . $e . qq{$1qq$2 $3}; }
3410 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin4::split' . $e . qq {q$1 $2}; }
3411 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin4::split' . $e . qq {$1q$2 $3}; }
3412 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin4::split' . $e . qq {$1q$2 $3}; }
3413 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin4::split' . $e . qq {$1q$2 $3}; }
3414 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin4::split' . $e . qq {$1q$2 $3}; }
3415 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin4::split' . $e . qq {$1q$2 $3}; }
3416 10         48 elsif (/\G ' [ ] ' /oxgc) { return 'Elatin4::split' . $e . qq {' '}; }
3417 0         0 elsif (/\G " [ ] " /oxgc) { return 'Elatin4::split' . $e . qq {" "}; }
3418              
3419             # split qq//
3420             elsif (/\G \b (qq) \b /oxgc) {
3421 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3422             else {
3423 0         0 while (not /\G \z/oxgc) {
3424 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3425 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3426 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3427 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3428 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3429 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3430 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3431             }
3432 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3433             }
3434             }
3435              
3436             # split qr//
3437             elsif (/\G \b (qr) \b /oxgc) {
3438 12 50       583 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3439             else {
3440 12         69 while (not /\G \z/oxgc) {
3441 12 50       4418 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3442 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3443 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3444 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3445 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3446 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3447 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3448 12         83 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3449             }
3450 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3451             }
3452             }
3453              
3454             # split q//
3455             elsif (/\G \b (q) \b /oxgc) {
3456 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3457             else {
3458 0         0 while (not /\G \z/oxgc) {
3459 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3460 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3461 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3462 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3463 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3464 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3465 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3466             }
3467 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3468             }
3469             }
3470              
3471             # split m//
3472             elsif (/\G \b (m) \b /oxgc) {
3473 18 50       646 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3474             else {
3475 18         89 while (not /\G \z/oxgc) {
3476 18 50       4683 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3477 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3478 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3479 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3480 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3481 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3482 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3483 18         112 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3484             }
3485 0         0 die __FILE__, ": Search pattern not terminated\n";
3486             }
3487             }
3488              
3489             # split ''
3490             elsif (/\G (\') /oxgc) {
3491 0         0 my $q_string = '';
3492 0         0 while (not /\G \z/oxgc) {
3493 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3494 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3495 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3496 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3497             }
3498 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3499             }
3500              
3501             # split ""
3502             elsif (/\G (\") /oxgc) {
3503 0         0 my $qq_string = '';
3504 0         0 while (not /\G \z/oxgc) {
3505 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3506 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3507 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3508 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3509             }
3510 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3511             }
3512              
3513             # split //
3514             elsif (/\G (\/) /oxgc) {
3515 44         89 my $regexp = '';
3516 44         187 while (not /\G \z/oxgc) {
3517 381 50       1671 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3518 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3519 44         230 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3520 337         669 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3521             }
3522 0         0 die __FILE__, ": Search pattern not terminated\n";
3523             }
3524             }
3525              
3526             # tr/// or y///
3527              
3528             # about [cdsrbB]* (/B modifier)
3529             #
3530             # P.559 appendix C
3531             # of ISBN 4-89052-384-7 Programming perl
3532             # (Japanese title is: Perl puroguramingu)
3533              
3534             elsif (/\G \b ( tr | y ) \b /oxgc) {
3535 3         5 my $ope = $1;
3536              
3537             # $1 $2 $3 $4 $5 $6
3538 3 50       40 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3539 0         0 my @tr = ($tr_variable,$2);
3540 0         0 return e_tr(@tr,'',$4,$6);
3541             }
3542             else {
3543 3         4 my $e = '';
3544 3         8 while (not /\G \z/oxgc) {
3545 3 50       203 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3546             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3547 0         0 my @tr = ($tr_variable,$2);
3548 0         0 while (not /\G \z/oxgc) {
3549 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3550 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3551 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3552 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3553 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3554 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3555             }
3556 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3557             }
3558             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3559 0         0 my @tr = ($tr_variable,$2);
3560 0         0 while (not /\G \z/oxgc) {
3561 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3562 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3563 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3564 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3565 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3566 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3567             }
3568 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3569             }
3570             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3571 0         0 my @tr = ($tr_variable,$2);
3572 0         0 while (not /\G \z/oxgc) {
3573 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3574 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3575 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3576 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3577 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3578 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3579             }
3580 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3581             }
3582             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3583 0         0 my @tr = ($tr_variable,$2);
3584 0         0 while (not /\G \z/oxgc) {
3585 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3586 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3587 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3588 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3589 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3590 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3591             }
3592 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3593             }
3594             # $1 $2 $3 $4 $5 $6
3595             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3596 3         8 my @tr = ($tr_variable,$2);
3597 3         8 return e_tr(@tr,'',$4,$6);
3598             }
3599             }
3600 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3601             }
3602             }
3603              
3604             # qq//
3605             elsif (/\G \b (qq) \b /oxgc) {
3606 2130         4114 my $ope = $1;
3607              
3608             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3609 2130 50       3581 if (/\G (\#) /oxgc) { # qq# #
3610 0         0 my $qq_string = '';
3611 0         0 while (not /\G \z/oxgc) {
3612 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3613 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3614 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3615 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3616             }
3617 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3618             }
3619              
3620             else {
3621 2130         2194 my $e = '';
3622 2130         5126 while (not /\G \z/oxgc) {
3623 2130 50       8989 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3624              
3625             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3626             elsif (/\G (\() /oxgc) { # qq ( )
3627 0         0 my $qq_string = '';
3628 0         0 local $nest = 1;
3629 0         0 while (not /\G \z/oxgc) {
3630 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3631 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3632 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3633             elsif (/\G (\)) /oxgc) {
3634 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3635 0         0 else { $qq_string .= $1; }
3636             }
3637 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3638             }
3639 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3640             }
3641              
3642             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3643             elsif (/\G (\{) /oxgc) { # qq { }
3644 2100         2093 my $qq_string = '';
3645 2100         10817 local $nest = 1;
3646 2100         4562 while (not /\G \z/oxgc) {
3647 82644 100       290278 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1411  
    100          
    100          
    50          
3648 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3649 1103         1239 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         1927  
3650             elsif (/\G (\}) /oxgc) {
3651 3203 100       4376 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         4382  
3652 1103         2262 else { $qq_string .= $1; }
3653             }
3654 77616         156178 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3655             }
3656 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3657             }
3658              
3659             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3660             elsif (/\G (\[) /oxgc) { # qq [ ]
3661 0         0 my $qq_string = '';
3662 0         0 local $nest = 1;
3663 0         0 while (not /\G \z/oxgc) {
3664 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3665 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3666 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3667             elsif (/\G (\]) /oxgc) {
3668 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3669 0         0 else { $qq_string .= $1; }
3670             }
3671 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3672             }
3673 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3674             }
3675              
3676             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3677             elsif (/\G (\<) /oxgc) { # qq < >
3678 30         44 my $qq_string = '';
3679 30         47 local $nest = 1;
3680 30         93 while (not /\G \z/oxgc) {
3681 1166 100       4443 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       54  
    50          
    100          
    50          
3682 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3683 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3684             elsif (/\G (\>) /oxgc) {
3685 30 50       66 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         95  
3686 0         0 else { $qq_string .= $1; }
3687             }
3688 1114         2285 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3689             }
3690 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3691             }
3692              
3693             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3694             elsif (/\G (\S) /oxgc) { # qq * *
3695 0         0 my $delimiter = $1;
3696 0         0 my $qq_string = '';
3697 0         0 while (not /\G \z/oxgc) {
3698 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3699 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3700 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3701 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3702             }
3703 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3704             }
3705             }
3706 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3707             }
3708             }
3709              
3710             # qr//
3711             elsif (/\G \b (qr) \b /oxgc) {
3712 0         0 my $ope = $1;
3713 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3714 0         0 return e_qr($ope,$1,$3,$2,$4);
3715             }
3716             else {
3717 0         0 my $e = '';
3718 0         0 while (not /\G \z/oxgc) {
3719 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3720 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3721 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3722 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3723 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3724 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3725 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3726 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3727             }
3728 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3729             }
3730             }
3731              
3732             # qw//
3733             elsif (/\G \b (qw) \b /oxgc) {
3734 16         43 my $ope = $1;
3735 16 50       67 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3736 0         0 return e_qw($ope,$1,$3,$2);
3737             }
3738             else {
3739 16         26 my $e = '';
3740 16         61 while (not /\G \z/oxgc) {
3741 16 50       117 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3742              
3743 16         58 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3744 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3745              
3746 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3747 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3748              
3749 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3750 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3751              
3752 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3753 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3754              
3755 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3756 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3757             }
3758 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3759             }
3760             }
3761              
3762             # qx//
3763             elsif (/\G \b (qx) \b /oxgc) {
3764 0         0 my $ope = $1;
3765 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3766 0         0 return e_qq($ope,$1,$3,$2);
3767             }
3768             else {
3769 0         0 my $e = '';
3770 0         0 while (not /\G \z/oxgc) {
3771 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3772 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3773 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3774 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3775 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3776 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3777 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3778             }
3779 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3780             }
3781             }
3782              
3783             # q//
3784             elsif (/\G \b (q) \b /oxgc) {
3785 245         719 my $ope = $1;
3786              
3787             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3788              
3789             # avoid "Error: Runtime exception" of perl version 5.005_03
3790             # (and so on)
3791              
3792 245 50       812 if (/\G (\#) /oxgc) { # q# #
3793 0         0 my $q_string = '';
3794 0         0 while (not /\G \z/oxgc) {
3795 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3796 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3797 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3798 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3799             }
3800 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3801             }
3802              
3803             else {
3804 245         463 my $e = '';
3805 245         1461 while (not /\G \z/oxgc) {
3806 245 50       1901 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3807              
3808             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3809             elsif (/\G (\() /oxgc) { # q ( )
3810 0         0 my $q_string = '';
3811 0         0 local $nest = 1;
3812 0         0 while (not /\G \z/oxgc) {
3813 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3814 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3815 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3816 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3817             elsif (/\G (\)) /oxgc) {
3818 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3819 0         0 else { $q_string .= $1; }
3820             }
3821 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3822             }
3823 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3824             }
3825              
3826             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3827             elsif (/\G (\{) /oxgc) { # q { }
3828 239         435 my $q_string = '';
3829 239         483 local $nest = 1;
3830 239         892 while (not /\G \z/oxgc) {
3831 3637 50       18934 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3832 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3833 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3834 107         146 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         241  
3835             elsif (/\G (\}) /oxgc) {
3836 346 100       802 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         918  
3837 107         244 else { $q_string .= $1; }
3838             }
3839 3184         7501 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3840             }
3841 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3842             }
3843              
3844             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3845             elsif (/\G (\[) /oxgc) { # q [ ]
3846 0         0 my $q_string = '';
3847 0         0 local $nest = 1;
3848 0         0 while (not /\G \z/oxgc) {
3849 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3850 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3851 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3852 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3853             elsif (/\G (\]) /oxgc) {
3854 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3855 0         0 else { $q_string .= $1; }
3856             }
3857 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3858             }
3859 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3860             }
3861              
3862             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3863             elsif (/\G (\<) /oxgc) { # q < >
3864 5         13 my $q_string = '';
3865 5         13 local $nest = 1;
3866 5         70 while (not /\G \z/oxgc) {
3867 88 50       506 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3868 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3869 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3870 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3871             elsif (/\G (\>) /oxgc) {
3872 5 50       17 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         18  
3873 0         0 else { $q_string .= $1; }
3874             }
3875 83         176 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3876             }
3877 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3878             }
3879              
3880             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3881             elsif (/\G (\S) /oxgc) { # q * *
3882 1         3 my $delimiter = $1;
3883 1         3 my $q_string = '';
3884 1         4 while (not /\G \z/oxgc) {
3885 14 50       96 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3886 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3887 1         3 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3888 13         36 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3889             }
3890 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3891             }
3892             }
3893 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3894             }
3895             }
3896              
3897             # m//
3898             elsif (/\G \b (m) \b /oxgc) {
3899 209         491 my $ope = $1;
3900 209 50       1953 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3901 0         0 return e_qr($ope,$1,$3,$2,$4);
3902             }
3903             else {
3904 209         291 my $e = '';
3905 209         639 while (not /\G \z/oxgc) {
3906 209 50       13584 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3907 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3908 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3909 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3910 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3911 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3912 10         40 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3913 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3914 199         709 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3915             }
3916 0         0 die __FILE__, ": Search pattern not terminated\n";
3917             }
3918             }
3919              
3920             # s///
3921              
3922             # about [cegimosxpradlunbB]* (/cg modifier)
3923             #
3924             # P.67 Pattern-Matching Operators
3925             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3926              
3927             elsif (/\G \b (s) \b /oxgc) {
3928 97         229 my $ope = $1;
3929              
3930             # $1 $2 $3 $4 $5 $6
3931 97 100       2298 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3932 1         7 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3933             }
3934             else {
3935 96         162 my $e = '';
3936 96         328 while (not /\G \z/oxgc) {
3937 96 50       13151 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3938             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3939 0         0 my @s = ($1,$2,$3);
3940 0         0 while (not /\G \z/oxgc) {
3941 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3942             # $1 $2 $3 $4
3943 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952             }
3953 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3954             }
3955             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3956 0         0 my @s = ($1,$2,$3);
3957 0         0 while (not /\G \z/oxgc) {
3958 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3959             # $1 $2 $3 $4
3960 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969             }
3970 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3971             }
3972             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3973 0         0 my @s = ($1,$2,$3);
3974 0         0 while (not /\G \z/oxgc) {
3975 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3976             # $1 $2 $3 $4
3977 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984             }
3985 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3986             }
3987             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3988 0         0 my @s = ($1,$2,$3);
3989 0         0 while (not /\G \z/oxgc) {
3990 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3991             # $1 $2 $3 $4
3992 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3993 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3994 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3995 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3997 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3998 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3999 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4000 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4001             }
4002 0         0 die __FILE__, ": Substitution replacement not terminated\n";
4003             }
4004             # $1 $2 $3 $4 $5 $6
4005             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4006 21         84 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4007             }
4008             # $1 $2 $3 $4 $5 $6
4009             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4010 0         0 return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4011             }
4012             # $1 $2 $3 $4 $5 $6
4013             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4014 0         0 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4015             }
4016             # $1 $2 $3 $4 $5 $6
4017             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4018 75         326 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4019             }
4020             }
4021 0         0 die __FILE__, ": Substitution pattern not terminated\n";
4022             }
4023             }
4024              
4025             # require ignore module
4026 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4027 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4028 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4029              
4030             # use strict; --> use strict; no strict qw(refs);
4031 36         348 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4032 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4033 0         0 elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4034              
4035             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4036             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4037 2 50 33     29 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4038 0         0 return "use $1; no strict qw(refs);";
4039             }
4040             else {
4041 2         12 return "use $1;";
4042             }
4043             }
4044             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4045 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4046 0         0 return "use $1; no strict qw(refs);";
4047             }
4048             else {
4049 0         0 return "use $1;";
4050             }
4051             }
4052              
4053             # ignore use module
4054 2         24 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4055 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4056 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4057              
4058             # ignore no module
4059 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4060 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4061 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4062              
4063             # use else
4064 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4065              
4066             # use else
4067 2         9 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4068              
4069             # ''
4070             elsif (/\G (?
4071 841         1329 my $q_string = '';
4072 841         2369 while (not /\G \z/oxgc) {
4073 8209 100       30587 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       13  
    100          
    50          
4074 48         113 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4075 841         2050 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4076 7316         16686 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4077             }
4078 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4079             }
4080              
4081             # ""
4082             elsif (/\G (\") /oxgc) {
4083 1783         2651 my $qq_string = '';
4084 1783         4549 while (not /\G \z/oxgc) {
4085 34504 100       111045 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       184  
    100          
    50          
4086 12         26 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4087 1783         4130 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4088 32642         66703 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4089             }
4090 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4091             }
4092              
4093             # ``
4094             elsif (/\G (\`) /oxgc) {
4095 1         2 my $qx_string = '';
4096 1         3 while (not /\G \z/oxgc) {
4097 19 50       71 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4098 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4099 1         2 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4100 18         31 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4101             }
4102 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4103             }
4104              
4105             # // --- not divide operator (num / num), not defined-or
4106             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4107 452         818 my $regexp = '';
4108 452         1540 while (not /\G \z/oxgc) {
4109 4490 50       17157 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4110 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4111 452         1330 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4112 4038         8724 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4113             }
4114 0         0 die __FILE__, ": Search pattern not terminated\n";
4115             }
4116              
4117             # ?? --- not conditional operator (condition ? then : else)
4118             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4119 0         0 my $regexp = '';
4120 0         0 while (not /\G \z/oxgc) {
4121 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4122 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4123 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4124 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4125             }
4126 0         0 die __FILE__, ": Search pattern not terminated\n";
4127             }
4128              
4129             # <<>> (a safer ARGV)
4130 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4131              
4132             # << (bit shift) --- not here document
4133 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4134              
4135             # <<'HEREDOC'
4136             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4137 72         92 $slash = 'm//';
4138 72         151 my $here_quote = $1;
4139 72         108 my $delimiter = $2;
4140              
4141             # get here document
4142 72 50       141 if ($here_script eq '') {
4143 72         379 $here_script = CORE::substr $_, pos $_;
4144 72         428 $here_script =~ s/.*?\n//oxm;
4145             }
4146 72 50       642 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4147 72         237 push @heredoc, $1 . qq{\n$delimiter\n};
4148 72         119 push @heredoc_delimiter, $delimiter;
4149             }
4150             else {
4151 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4152             }
4153 72         314 return $here_quote;
4154             }
4155              
4156             # <<\HEREDOC
4157              
4158             # P.66 2.6.6. "Here" Documents
4159             # in Chapter 2: Bits and Pieces
4160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4161              
4162             # P.73 "Here" Documents
4163             # in Chapter 2: Bits and Pieces
4164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4165              
4166             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4167 0         0 $slash = 'm//';
4168 0         0 my $here_quote = $1;
4169 0         0 my $delimiter = $2;
4170              
4171             # get here document
4172 0 0       0 if ($here_script eq '') {
4173 0         0 $here_script = CORE::substr $_, pos $_;
4174 0         0 $here_script =~ s/.*?\n//oxm;
4175             }
4176 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4177 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4178 0         0 push @heredoc_delimiter, $delimiter;
4179             }
4180             else {
4181 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4182             }
4183 0         0 return $here_quote;
4184             }
4185              
4186             # <<"HEREDOC"
4187             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4188 36         62 $slash = 'm//';
4189 36         76 my $here_quote = $1;
4190 36         553 my $delimiter = $2;
4191              
4192             # get here document
4193 36 50       94 if ($here_script eq '') {
4194 36         262 $here_script = CORE::substr $_, pos $_;
4195 36         193 $here_script =~ s/.*?\n//oxm;
4196             }
4197 36 50       790 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4198 36         91 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4199 36         138 push @heredoc_delimiter, $delimiter;
4200             }
4201             else {
4202 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4203             }
4204 36         149 return $here_quote;
4205             }
4206              
4207             # <
4208             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4209 42         91 $slash = 'm//';
4210 42         104 my $here_quote = $1;
4211 42         97 my $delimiter = $2;
4212              
4213             # get here document
4214 42 50       143 if ($here_script eq '') {
4215 42         441 $here_script = CORE::substr $_, pos $_;
4216 42         355 $here_script =~ s/.*?\n//oxm;
4217             }
4218 42 50       677 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4219 42         156 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4220 42         100 push @heredoc_delimiter, $delimiter;
4221             }
4222             else {
4223 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4224             }
4225 42         221 return $here_quote;
4226             }
4227              
4228             # <<`HEREDOC`
4229             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4230 0         0 $slash = 'm//';
4231 0         0 my $here_quote = $1;
4232 0         0 my $delimiter = $2;
4233              
4234             # get here document
4235 0 0       0 if ($here_script eq '') {
4236 0         0 $here_script = CORE::substr $_, pos $_;
4237 0         0 $here_script =~ s/.*?\n//oxm;
4238             }
4239 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4240 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4241 0         0 push @heredoc_delimiter, $delimiter;
4242             }
4243             else {
4244 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4245             }
4246 0         0 return $here_quote;
4247             }
4248              
4249             # <<= <=> <= < operator
4250             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4251 11         59 return $1;
4252             }
4253              
4254             #
4255             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4256 0         0 return $1;
4257             }
4258              
4259             # --- glob
4260              
4261             # avoid "Error: Runtime exception" of perl version 5.005_03
4262              
4263             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4264 0         0 return 'Elatin4::glob("' . $1 . '")';
4265             }
4266              
4267             # __DATA__
4268 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4269              
4270             # __END__
4271 200         1596 elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4272              
4273             # \cD Control-D
4274              
4275             # P.68 2.6.8. Other Literal Tokens
4276             # in Chapter 2: Bits and Pieces
4277             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4278              
4279             # P.76 Other Literal Tokens
4280             # in Chapter 2: Bits and Pieces
4281             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4282              
4283 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4284              
4285             # \cZ Control-Z
4286 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4287              
4288             # any operator before div
4289             elsif (/\G (
4290             -- | \+\+ |
4291             [\)\}\]]
4292              
4293 4824         6428 ) /oxgc) { $slash = 'div'; return $1; }
  4824         22094  
4294              
4295             # yada-yada or triple-dot operator
4296             elsif (/\G (
4297             \.\.\.
4298              
4299 7         10 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         30  
4300              
4301             # any operator before m//
4302              
4303             # //, //= (defined-or)
4304              
4305             # P.164 Logical Operators
4306             # in Chapter 10: More Control Structures
4307             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4308              
4309             # P.119 C-Style Logical (Short-Circuit) Operators
4310             # in Chapter 3: Unary and Binary Operators
4311             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4312              
4313             # (and so on)
4314              
4315             # ~~
4316              
4317             # P.221 The Smart Match Operator
4318             # in Chapter 15: Smart Matching and given-when
4319             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4320              
4321             # P.112 Smartmatch Operator
4322             # in Chapter 3: Unary and Binary Operators
4323             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4324              
4325             # (and so on)
4326              
4327             elsif (/\G ((?>
4328              
4329             !~~ | !~ | != | ! |
4330             %= | % |
4331             &&= | && | &= | &\.= | &\. | & |
4332             -= | -> | - |
4333             :(?>\s*)= |
4334             : |
4335             <<>> |
4336             <<= | <=> | <= | < |
4337             == | => | =~ | = |
4338             >>= | >> | >= | > |
4339             \*\*= | \*\* | \*= | \* |
4340             \+= | \+ |
4341             \.\. | \.= | \. |
4342             \/\/= | \/\/ |
4343             \/= | \/ |
4344             \? |
4345             \\ |
4346             \^= | \^\.= | \^\. | \^ |
4347             \b x= |
4348             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4349             ~~ | ~\. | ~ |
4350             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4351             \b(?: print )\b |
4352              
4353             [,;\(\{\[]
4354              
4355 8503         10515 )) /oxgc) { $slash = 'm//'; return $1; }
  8503         37565  
4356              
4357             # other any character
4358 14740         17382 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14740         66672  
4359              
4360             # system error
4361             else {
4362 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4363             }
4364             }
4365              
4366             # escape Latin-4 string
4367             sub e_string {
4368 1718     1718 0 3352 my($string) = @_;
4369 1718         1930 my $e_string = '';
4370              
4371 1718         2231 local $slash = 'm//';
4372              
4373             # P.1024 Appendix W.10 Multibyte Processing
4374             # of ISBN 1-56592-224-7 CJKV Information Processing
4375             # (and so on)
4376              
4377 1718         17088 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4378              
4379             # without { ... }
4380 1718 100 66     8184 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4381 1701 50       3639 if ($string !~ /<
4382 1701         4134 return $string;
4383             }
4384             }
4385              
4386             E_STRING_LOOP:
4387 17         50 while ($string !~ /\G \z/oxgc) {
4388 190 50       12221 if (0) {
    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          
    100          
    50          
    100          
    50          
4389             }
4390              
4391             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin4::PREMATCH()]}
4392 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4393 0         0 $e_string .= q{Elatin4::PREMATCH()};
4394 0         0 $slash = 'div';
4395             }
4396              
4397             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin4::MATCH()]}
4398             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4399 0         0 $e_string .= q{Elatin4::MATCH()};
4400 0         0 $slash = 'div';
4401             }
4402              
4403             # $', ${'} --> $', ${'}
4404             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4405 0         0 $e_string .= $1;
4406 0         0 $slash = 'div';
4407             }
4408              
4409             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin4::POSTMATCH()]}
4410             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4411 0         0 $e_string .= q{Elatin4::POSTMATCH()};
4412 0         0 $slash = 'div';
4413             }
4414              
4415             # bareword
4416             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4417 0         0 $e_string .= $1;
4418 0         0 $slash = 'div';
4419             }
4420              
4421             # $0 --> $0
4422             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4423 0         0 $e_string .= $1;
4424 0         0 $slash = 'div';
4425             }
4426             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4427 0         0 $e_string .= $1;
4428 0         0 $slash = 'div';
4429             }
4430              
4431             # $$ --> $$
4432             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4433 0         0 $e_string .= $1;
4434 0         0 $slash = 'div';
4435             }
4436              
4437             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4438             # $1, $2, $3 --> $1, $2, $3 otherwise
4439             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4440 0         0 $e_string .= e_capture($1);
4441 0         0 $slash = 'div';
4442             }
4443             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4444 0         0 $e_string .= e_capture($1);
4445 0         0 $slash = 'div';
4446             }
4447              
4448             # $$foo[ ... ] --> $ $foo->[ ... ]
4449             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4450 0         0 $e_string .= e_capture($1.'->'.$2);
4451 0         0 $slash = 'div';
4452             }
4453              
4454             # $$foo{ ... } --> $ $foo->{ ... }
4455             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4456 0         0 $e_string .= e_capture($1.'->'.$2);
4457 0         0 $slash = 'div';
4458             }
4459              
4460             # $$foo
4461             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4462 0         0 $e_string .= e_capture($1);
4463 0         0 $slash = 'div';
4464             }
4465              
4466             # ${ foo }
4467             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4468 0         0 $e_string .= '${' . $1 . '}';
4469 0         0 $slash = 'div';
4470             }
4471              
4472             # ${ ... }
4473             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4474 3         8 $e_string .= e_capture($1);
4475 3         11 $slash = 'div';
4476             }
4477              
4478             # variable or function
4479             # $ @ % & * $ #
4480             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) {
4481 7         12 $e_string .= $1;
4482 7         18 $slash = 'div';
4483             }
4484             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4485             # $ @ # \ ' " / ? ( ) [ ] < >
4486             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4487 0         0 $e_string .= $1;
4488 0         0 $slash = 'div';
4489             }
4490              
4491             # subroutines of package Elatin4
4492 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4493 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4494 0         0 elsif ($string =~ /\G \b Latin4::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4495 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4496 0         0 elsif ($string =~ /\G \b Latin4::eval \b /oxgc) { $e_string .= 'eval Latin4::escape'; $slash = 'm//'; }
  0         0  
4497 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4498 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin4::chop'; $slash = 'm//'; }
  0         0  
4499 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4500 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4501 0         0 elsif ($string =~ /\G \b Latin4::index \b /oxgc) { $e_string .= 'Latin4::index'; $slash = 'm//'; }
  0         0  
4502 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin4::index'; $slash = 'm//'; }
  0         0  
4503 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4504 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4505 0         0 elsif ($string =~ /\G \b Latin4::rindex \b /oxgc) { $e_string .= 'Latin4::rindex'; $slash = 'm//'; }
  0         0  
4506 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin4::rindex'; $slash = 'm//'; }
  0         0  
4507 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin4::lc'; $slash = 'm//'; }
  0         0  
4508 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin4::lcfirst'; $slash = 'm//'; }
  0         0  
4509 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin4::uc'; $slash = 'm//'; }
  0         0  
4510 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin4::ucfirst'; $slash = 'm//'; }
  0         0  
4511 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin4::fc'; $slash = 'm//'; }
  0         0  
4512              
4513             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4514 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4515 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  
4516 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  
4517 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  
4518 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  
4519 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4520 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  
4521              
4522 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4523 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  
4524 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  
4525 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  
4526 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  
4527 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4528 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4529              
4530             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4531 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4532 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4533 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4534 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4535              
4536 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4537 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4538 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin4::chr'; $slash = 'm//'; }
  0         0  
4539 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4540 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4541 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin4::glob'; $slash = 'm//'; }
  0         0  
4542 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin4::lc_'; $slash = 'm//'; }
  0         0  
4543 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin4::lcfirst_'; $slash = 'm//'; }
  0         0  
4544 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin4::uc_'; $slash = 'm//'; }
  0         0  
4545 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin4::ucfirst_'; $slash = 'm//'; }
  0         0  
4546 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin4::fc_'; $slash = 'm//'; }
  0         0  
4547 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4548              
4549 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4550 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4551 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin4::chr_'; $slash = 'm//'; }
  0         0  
4552 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4553 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4554 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin4::glob_'; $slash = 'm//'; }
  0         0  
4555 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4556 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4557             # split
4558             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4559 0         0 $slash = 'm//';
4560              
4561 0         0 my $e = '';
4562 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4563 0         0 $e .= $1;
4564             }
4565              
4566             # end of split
4567 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin4::split' . $e; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4568              
4569             # split scalar value
4570 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin4::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4571              
4572             # split literal space
4573 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4574 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4575 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4576 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4577 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4578 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4579 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4580 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4581 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4582 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4583 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4584 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4585 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4586 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin4::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4587              
4588             # split qq//
4589             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4590 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0         0  
  0         0  
4591             else {
4592 0         0 while ($string !~ /\G \z/oxgc) {
4593 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4594 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  
4595 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  
4596 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  
4597 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  
4598 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4599 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 * *
  0         0  
4600             }
4601 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4602             }
4603             }
4604              
4605             # split qr//
4606             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4607 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0         0  
  0         0  
4608             else {
4609 0         0 while ($string !~ /\G \z/oxgc) {
4610 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4611 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  
4612 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  
4613 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  
4614 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  
4615 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  
4616 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0         0  
4617 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 * *
  0         0  
4618             }
4619 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4620             }
4621             }
4622              
4623             # split q//
4624             elsif ($string =~ /\G \b (q) \b /oxgc) {
4625 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0         0  
  0         0  
4626             else {
4627 0         0 while ($string !~ /\G \z/oxgc) {
4628 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4629 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  
4630 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  
4631 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  
4632 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  
4633 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0         0  
4634 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 * *
  0         0  
4635             }
4636 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4637             }
4638             }
4639              
4640             # split m//
4641             elsif ($string =~ /\G \b (m) \b /oxgc) {
4642 0 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 # #
  0         0  
  0         0  
4643             else {
4644 0         0 while ($string !~ /\G \z/oxgc) {
4645 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4646 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  
4647 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  
4648 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  
4649 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  
4650 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  
4651 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0         0  
4652 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 * *
  0         0  
4653             }
4654 0         0 die __FILE__, ": Search pattern not terminated\n";
4655             }
4656             }
4657              
4658             # split ''
4659             elsif ($string =~ /\G (\') /oxgc) {
4660 0         0 my $q_string = '';
4661 0         0 while ($string !~ /\G \z/oxgc) {
4662 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4663 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4664 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4665 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4666             }
4667 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4668             }
4669              
4670             # split ""
4671             elsif ($string =~ /\G (\") /oxgc) {
4672 0         0 my $qq_string = '';
4673 0         0 while ($string !~ /\G \z/oxgc) {
4674 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4675 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4676 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4677 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4678             }
4679 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4680             }
4681              
4682             # split //
4683             elsif ($string =~ /\G (\/) /oxgc) {
4684 0         0 my $regexp = '';
4685 0         0 while ($string !~ /\G \z/oxgc) {
4686 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4687 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4688 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4689 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4690             }
4691 0         0 die __FILE__, ": Search pattern not terminated\n";
4692             }
4693             }
4694              
4695             # qq//
4696             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4697 0         0 my $ope = $1;
4698 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4699 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4700             }
4701             else {
4702 0         0 my $e = '';
4703 0         0 while ($string !~ /\G \z/oxgc) {
4704 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4705 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4706 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4707 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4708 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4709 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0         0  
4710             }
4711 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4712             }
4713             }
4714              
4715             # qx//
4716             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4717 0         0 my $ope = $1;
4718 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4719 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4720             }
4721             else {
4722 0         0 my $e = '';
4723 0         0 while ($string !~ /\G \z/oxgc) {
4724 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4725 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4726 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4727 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4728 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4729 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4730 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0         0  
4731             }
4732 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4733             }
4734             }
4735              
4736             # q//
4737             elsif ($string =~ /\G \b (q) \b /oxgc) {
4738 0         0 my $ope = $1;
4739 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4740 0         0 $e_string .= e_q($ope,$1,$3,$2);
4741             }
4742             else {
4743 0         0 my $e = '';
4744 0         0 while ($string !~ /\G \z/oxgc) {
4745 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4746 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4747 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4748 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4749 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4750 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 * *
  0         0  
4751             }
4752 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4753             }
4754             }
4755              
4756             # ''
4757 0         0 elsif ($string =~ /\G (?
4758              
4759             # ""
4760 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4761              
4762             # ``
4763 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4764              
4765             # <<>> (a safer ARGV)
4766 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4767              
4768             # <<= <=> <= < operator
4769 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4770              
4771             #
4772 0         0 elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4773              
4774             # --- glob
4775             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4776 0         0 $e_string .= 'Elatin4::glob("' . $1 . '")';
4777             }
4778              
4779             # << (bit shift) --- not here document
4780 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4781              
4782             # <<'HEREDOC'
4783             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4784 0         0 $slash = 'm//';
4785 0         0 my $here_quote = $1;
4786 0         0 my $delimiter = $2;
4787              
4788             # get here document
4789 0 0       0 if ($here_script eq '') {
4790 0         0 $here_script = CORE::substr $_, pos $_;
4791 0         0 $here_script =~ s/.*?\n//oxm;
4792             }
4793 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4794 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4795 0         0 push @heredoc_delimiter, $delimiter;
4796             }
4797             else {
4798 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4799             }
4800 0         0 $e_string .= $here_quote;
4801             }
4802              
4803             # <<\HEREDOC
4804             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4805 0         0 $slash = 'm//';
4806 0         0 my $here_quote = $1;
4807 0         0 my $delimiter = $2;
4808              
4809             # get here document
4810 0 0       0 if ($here_script eq '') {
4811 0         0 $here_script = CORE::substr $_, pos $_;
4812 0         0 $here_script =~ s/.*?\n//oxm;
4813             }
4814 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4815 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4816 0         0 push @heredoc_delimiter, $delimiter;
4817             }
4818             else {
4819 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4820             }
4821 0         0 $e_string .= $here_quote;
4822             }
4823              
4824             # <<"HEREDOC"
4825             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4826 0         0 $slash = 'm//';
4827 0         0 my $here_quote = $1;
4828 0         0 my $delimiter = $2;
4829              
4830             # get here document
4831 0 0       0 if ($here_script eq '') {
4832 0         0 $here_script = CORE::substr $_, pos $_;
4833 0         0 $here_script =~ s/.*?\n//oxm;
4834             }
4835 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4836 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4837 0         0 push @heredoc_delimiter, $delimiter;
4838             }
4839             else {
4840 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4841             }
4842 0         0 $e_string .= $here_quote;
4843             }
4844              
4845             # <
4846             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4847 0         0 $slash = 'm//';
4848 0         0 my $here_quote = $1;
4849 0         0 my $delimiter = $2;
4850              
4851             # get here document
4852 0 0       0 if ($here_script eq '') {
4853 0         0 $here_script = CORE::substr $_, pos $_;
4854 0         0 $here_script =~ s/.*?\n//oxm;
4855             }
4856 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4857 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4858 0         0 push @heredoc_delimiter, $delimiter;
4859             }
4860             else {
4861 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4862             }
4863 0         0 $e_string .= $here_quote;
4864             }
4865              
4866             # <<`HEREDOC`
4867             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4868 0         0 $slash = 'm//';
4869 0         0 my $here_quote = $1;
4870 0         0 my $delimiter = $2;
4871              
4872             # get here document
4873 0 0       0 if ($here_script eq '') {
4874 0         0 $here_script = CORE::substr $_, pos $_;
4875 0         0 $here_script =~ s/.*?\n//oxm;
4876             }
4877 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4878 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4879 0         0 push @heredoc_delimiter, $delimiter;
4880             }
4881             else {
4882 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4883             }
4884 0         0 $e_string .= $here_quote;
4885             }
4886              
4887             # any operator before div
4888             elsif ($string =~ /\G (
4889             -- | \+\+ |
4890             [\)\}\]]
4891              
4892 18         25 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         59  
4893              
4894             # yada-yada or triple-dot operator
4895             elsif ($string =~ /\G (
4896             \.\.\.
4897              
4898 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         0  
4899              
4900             # any operator before m//
4901             elsif ($string =~ /\G ((?>
4902              
4903             !~~ | !~ | != | ! |
4904             %= | % |
4905             &&= | && | &= | &\.= | &\. | & |
4906             -= | -> | - |
4907             :(?>\s*)= |
4908             : |
4909             <<>> |
4910             <<= | <=> | <= | < |
4911             == | => | =~ | = |
4912             >>= | >> | >= | > |
4913             \*\*= | \*\* | \*= | \* |
4914             \+= | \+ |
4915             \.\. | \.= | \. |
4916             \/\/= | \/\/ |
4917             \/= | \/ |
4918             \? |
4919             \\ |
4920             \^= | \^\.= | \^\. | \^ |
4921             \b x= |
4922             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4923             ~~ | ~\. | ~ |
4924             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4925             \b(?: print )\b |
4926              
4927             [,;\(\{\[]
4928              
4929 31         40 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         99  
4930              
4931             # other any character
4932 131         344 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4933              
4934             # system error
4935             else {
4936 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4937             }
4938             }
4939              
4940 17         74 return $e_string;
4941             }
4942              
4943             #
4944             # character class
4945             #
4946             sub character_class {
4947 1914     1914 0 2435 my($char,$modifier) = @_;
4948              
4949 1914 100       2967 if ($char eq '.') {
4950 52 100       105 if ($modifier =~ /s/) {
4951 17         38 return '${Elatin4::dot_s}';
4952             }
4953             else {
4954 35         106 return '${Elatin4::dot}';
4955             }
4956             }
4957             else {
4958 1862         3357 return Elatin4::classic_character_class($char);
4959             }
4960             }
4961              
4962             #
4963             # escape capture ($1, $2, $3, ...)
4964             #
4965             sub e_capture {
4966              
4967 212     212 0 975 return join '', '${', $_[0], '}';
4968             }
4969              
4970             #
4971             # escape transliteration (tr/// or y///)
4972             #
4973             sub e_tr {
4974 3     3 0 7 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4975 3         4 my $e_tr = '';
4976 3   50     5 $modifier ||= '';
4977              
4978 3         7 $slash = 'div';
4979              
4980             # quote character class 1
4981 3         4 $charclass = q_tr($charclass);
4982              
4983             # quote character class 2
4984 3         6 $charclass2 = q_tr($charclass2);
4985              
4986             # /b /B modifier
4987 3 50       7 if ($modifier =~ tr/bB//d) {
4988 0 0       0 if ($variable eq '') {
4989 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4990             }
4991             else {
4992 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4993             }
4994             }
4995             else {
4996 3 100       6 if ($variable eq '') {
4997 2         4 $e_tr = qq{Elatin4::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4998             }
4999             else {
5000 1         4 $e_tr = qq{Elatin4::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5001             }
5002             }
5003              
5004             # clear tr/// variable
5005 3         4 $tr_variable = '';
5006 3         3 $bind_operator = '';
5007              
5008 3         14 return $e_tr;
5009             }
5010              
5011             #
5012             # quote for escape transliteration (tr/// or y///)
5013             #
5014             sub q_tr {
5015 6     6 0 3 my($charclass) = @_;
5016              
5017             # quote character class
5018 6 50       10 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5019 6         9 return e_q('', "'", "'", $charclass); # --> q' '
5020             }
5021             elsif ($charclass !~ /\//oxms) {
5022 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
5023             }
5024             elsif ($charclass !~ /\#/oxms) {
5025 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
5026             }
5027             elsif ($charclass !~ /[\<\>]/oxms) {
5028 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
5029             }
5030             elsif ($charclass !~ /[\(\)]/oxms) {
5031 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
5032             }
5033             elsif ($charclass !~ /[\{\}]/oxms) {
5034 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5035             }
5036             else {
5037 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5038 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5039 0         0 return e_q('q', $char, $char, $charclass);
5040             }
5041             }
5042             }
5043              
5044 0         0 return e_q('q', '{', '}', $charclass);
5045             }
5046              
5047             #
5048             # escape q string (q//, '')
5049             #
5050             sub e_q {
5051 1092     1092 0 2229 my($ope,$delimiter,$end_delimiter,$string) = @_;
5052              
5053 1092         1347 $slash = 'div';
5054              
5055 1092         6040 return join '', $ope, $delimiter, $string, $end_delimiter;
5056             }
5057              
5058             #
5059             # escape qq string (qq//, "", qx//, ``)
5060             #
5061             sub e_qq {
5062 3995     3995 0 7146 my($ope,$delimiter,$end_delimiter,$string) = @_;
5063              
5064 3995         4386 $slash = 'div';
5065              
5066 3995         3825 my $left_e = 0;
5067 3995         3312 my $right_e = 0;
5068              
5069             # split regexp
5070 3995         160503 my @char = $string =~ /\G((?>
5071             [^\\\$] |
5072             \\x\{ (?>[0-9A-Fa-f]+) \} |
5073             \\o\{ (?>[0-7]+) \} |
5074             \\N\{ (?>[^0-9\}][^\}]*) \} |
5075             \\ $q_char |
5076             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5077             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5078             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5079             \$ (?>\s* [0-9]+) |
5080             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5081             \$ \$ (?![\w\{]) |
5082             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5083             $q_char
5084             ))/oxmsg;
5085              
5086 3995         15167 for (my $i=0; $i <= $#char; $i++) {
5087              
5088             # "\L\u" --> "\u\L"
5089 111960 50 33     471573 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5090 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5091             }
5092              
5093             # "\U\l" --> "\l\U"
5094             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5095 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5096             }
5097              
5098             # octal escape sequence
5099             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5100 1         4 $char[$i] = Elatin4::octchr($1);
5101             }
5102              
5103             # hexadecimal escape sequence
5104             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5105 1         5 $char[$i] = Elatin4::hexchr($1);
5106             }
5107              
5108             # \N{CHARNAME} --> N{CHARNAME}
5109             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5110 0         0 $char[$i] = $1;
5111             }
5112              
5113 111960 100       1258868 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5114             }
5115              
5116             # \F
5117             #
5118             # P.69 Table 2-6. Translation escapes
5119             # in Chapter 2: Bits and Pieces
5120             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5121             # (and so on)
5122              
5123             # \u \l \U \L \F \Q \E
5124 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5125 484 50       1272 if ($right_e < $left_e) {
5126 0         0 $char[$i] = '\\' . $char[$i];
5127             }
5128             }
5129             elsif ($char[$i] eq '\u') {
5130              
5131             # "STRING @{[ LIST EXPR ]} MORE STRING"
5132              
5133             # P.257 Other Tricks You Can Do with Hard References
5134             # in Chapter 8: References
5135             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5136              
5137             # P.353 Other Tricks You Can Do with Hard References
5138             # in Chapter 8: References
5139             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5140              
5141             # (and so on)
5142              
5143 0         0 $char[$i] = '@{[Elatin4::ucfirst qq<';
5144 0         0 $left_e++;
5145             }
5146             elsif ($char[$i] eq '\l') {
5147 0         0 $char[$i] = '@{[Elatin4::lcfirst qq<';
5148 0         0 $left_e++;
5149             }
5150             elsif ($char[$i] eq '\U') {
5151 0         0 $char[$i] = '@{[Elatin4::uc qq<';
5152 0         0 $left_e++;
5153             }
5154             elsif ($char[$i] eq '\L') {
5155 0         0 $char[$i] = '@{[Elatin4::lc qq<';
5156 0         0 $left_e++;
5157             }
5158             elsif ($char[$i] eq '\F') {
5159 24         25 $char[$i] = '@{[Elatin4::fc qq<';
5160 24         42 $left_e++;
5161             }
5162             elsif ($char[$i] eq '\Q') {
5163 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5164 0         0 $left_e++;
5165             }
5166             elsif ($char[$i] eq '\E') {
5167 24 50       32 if ($right_e < $left_e) {
5168 24         24 $char[$i] = '>]}';
5169 24         41 $right_e++;
5170             }
5171             else {
5172 0         0 $char[$i] = '';
5173             }
5174             }
5175             elsif ($char[$i] eq '\Q') {
5176 0         0 while (1) {
5177 0 0       0 if (++$i > $#char) {
5178 0         0 last;
5179             }
5180 0 0       0 if ($char[$i] eq '\E') {
5181 0         0 last;
5182             }
5183             }
5184             }
5185             elsif ($char[$i] eq '\E') {
5186             }
5187              
5188             # $0 --> $0
5189             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5190             }
5191             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5192             }
5193              
5194             # $$ --> $$
5195             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5196             }
5197              
5198             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5199             # $1, $2, $3 --> $1, $2, $3 otherwise
5200             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5201 205         415 $char[$i] = e_capture($1);
5202             }
5203             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5204 0         0 $char[$i] = e_capture($1);
5205             }
5206              
5207             # $$foo[ ... ] --> $ $foo->[ ... ]
5208             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5209 0         0 $char[$i] = e_capture($1.'->'.$2);
5210             }
5211              
5212             # $$foo{ ... } --> $ $foo->{ ... }
5213             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5214 0         0 $char[$i] = e_capture($1.'->'.$2);
5215             }
5216              
5217             # $$foo
5218             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5219 0         0 $char[$i] = e_capture($1);
5220             }
5221              
5222             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin4::PREMATCH()
5223             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5224 44         157 $char[$i] = '@{[Elatin4::PREMATCH()]}';
5225             }
5226              
5227             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin4::MATCH()
5228             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5229 45         142 $char[$i] = '@{[Elatin4::MATCH()]}';
5230             }
5231              
5232             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin4::POSTMATCH()
5233             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5234 33         117 $char[$i] = '@{[Elatin4::POSTMATCH()]}';
5235             }
5236              
5237             # ${ foo } --> ${ foo }
5238             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5239             }
5240              
5241             # ${ ... }
5242             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5243 0         0 $char[$i] = e_capture($1);
5244             }
5245             }
5246              
5247             # return string
5248 3995 50       7289 if ($left_e > $right_e) {
5249 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5250             }
5251 3995         38783 return join '', $ope, $delimiter, @char, $end_delimiter;
5252             }
5253              
5254             #
5255             # escape qw string (qw//)
5256             #
5257             sub e_qw {
5258 16     16 0 110 my($ope,$delimiter,$end_delimiter,$string) = @_;
5259              
5260 16         24 $slash = 'div';
5261              
5262             # choice again delimiter
5263 16         200 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         579  
5264 16 50       119 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5265 16         129 return join '', $ope, $delimiter, $string, $end_delimiter;
5266             }
5267             elsif (not $octet{')'}) {
5268 0         0 return join '', $ope, '(', $string, ')';
5269             }
5270             elsif (not $octet{'}'}) {
5271 0         0 return join '', $ope, '{', $string, '}';
5272             }
5273             elsif (not $octet{']'}) {
5274 0         0 return join '', $ope, '[', $string, ']';
5275             }
5276             elsif (not $octet{'>'}) {
5277 0         0 return join '', $ope, '<', $string, '>';
5278             }
5279             else {
5280 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5281 0 0       0 if (not $octet{$char}) {
5282 0         0 return join '', $ope, $char, $string, $char;
5283             }
5284             }
5285             }
5286              
5287             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5288 0         0 my @string = CORE::split(/\s+/, $string);
5289 0         0 for my $string (@string) {
5290 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5291 0         0 for my $octet (@octet) {
5292 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5293 0         0 $octet = '\\' . $1;
5294             }
5295             }
5296 0         0 $string = join '', @octet;
5297             }
5298 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5299             }
5300              
5301             #
5302             # escape here document (<<"HEREDOC", <
5303             #
5304             sub e_heredoc {
5305 78     78 0 195 my($string) = @_;
5306              
5307 78         129 $slash = 'm//';
5308              
5309 78         306 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5310              
5311 78         103 my $left_e = 0;
5312 78         89 my $right_e = 0;
5313              
5314             # split regexp
5315 78         8278 my @char = $string =~ /\G((?>
5316             [^\\\$] |
5317             \\x\{ (?>[0-9A-Fa-f]+) \} |
5318             \\o\{ (?>[0-7]+) \} |
5319             \\N\{ (?>[^0-9\}][^\}]*) \} |
5320             \\ $q_char |
5321             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5322             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5323             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5324             \$ (?>\s* [0-9]+) |
5325             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5326             \$ \$ (?![\w\{]) |
5327             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5328             $q_char
5329             ))/oxmsg;
5330              
5331 78         457 for (my $i=0; $i <= $#char; $i++) {
5332              
5333             # "\L\u" --> "\u\L"
5334 2882 50 33     12170 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5335 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5336             }
5337              
5338             # "\U\l" --> "\l\U"
5339             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5340 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5341             }
5342              
5343             # octal escape sequence
5344             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5345 1         9 $char[$i] = Elatin4::octchr($1);
5346             }
5347              
5348             # hexadecimal escape sequence
5349             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5350 1         3 $char[$i] = Elatin4::hexchr($1);
5351             }
5352              
5353             # \N{CHARNAME} --> N{CHARNAME}
5354             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5355 0         0 $char[$i] = $1;
5356             }
5357              
5358 2882 50       35492 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5359             }
5360              
5361             # \u \l \U \L \F \Q \E
5362 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5363 0 0       0 if ($right_e < $left_e) {
5364 0         0 $char[$i] = '\\' . $char[$i];
5365             }
5366             }
5367             elsif ($char[$i] eq '\u') {
5368 0         0 $char[$i] = '@{[Elatin4::ucfirst qq<';
5369 0         0 $left_e++;
5370             }
5371             elsif ($char[$i] eq '\l') {
5372 0         0 $char[$i] = '@{[Elatin4::lcfirst qq<';
5373 0         0 $left_e++;
5374             }
5375             elsif ($char[$i] eq '\U') {
5376 0         0 $char[$i] = '@{[Elatin4::uc qq<';
5377 0         0 $left_e++;
5378             }
5379             elsif ($char[$i] eq '\L') {
5380 0         0 $char[$i] = '@{[Elatin4::lc qq<';
5381 0         0 $left_e++;
5382             }
5383             elsif ($char[$i] eq '\F') {
5384 0         0 $char[$i] = '@{[Elatin4::fc qq<';
5385 0         0 $left_e++;
5386             }
5387             elsif ($char[$i] eq '\Q') {
5388 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5389 0         0 $left_e++;
5390             }
5391             elsif ($char[$i] eq '\E') {
5392 0 0       0 if ($right_e < $left_e) {
5393 0         0 $char[$i] = '>]}';
5394 0         0 $right_e++;
5395             }
5396             else {
5397 0         0 $char[$i] = '';
5398             }
5399             }
5400             elsif ($char[$i] eq '\Q') {
5401 0         0 while (1) {
5402 0 0       0 if (++$i > $#char) {
5403 0         0 last;
5404             }
5405 0 0       0 if ($char[$i] eq '\E') {
5406 0         0 last;
5407             }
5408             }
5409             }
5410             elsif ($char[$i] eq '\E') {
5411             }
5412              
5413             # $0 --> $0
5414             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5415             }
5416             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5417             }
5418              
5419             # $$ --> $$
5420             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5421             }
5422              
5423             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5424             # $1, $2, $3 --> $1, $2, $3 otherwise
5425             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5426 0         0 $char[$i] = e_capture($1);
5427             }
5428             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5429 0         0 $char[$i] = e_capture($1);
5430             }
5431              
5432             # $$foo[ ... ] --> $ $foo->[ ... ]
5433             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5434 0         0 $char[$i] = e_capture($1.'->'.$2);
5435             }
5436              
5437             # $$foo{ ... } --> $ $foo->{ ... }
5438             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5439 0         0 $char[$i] = e_capture($1.'->'.$2);
5440             }
5441              
5442             # $$foo
5443             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5444 0         0 $char[$i] = e_capture($1);
5445             }
5446              
5447             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin4::PREMATCH()
5448             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5449 8         48 $char[$i] = '@{[Elatin4::PREMATCH()]}';
5450             }
5451              
5452             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin4::MATCH()
5453             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5454 8         53 $char[$i] = '@{[Elatin4::MATCH()]}';
5455             }
5456              
5457             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin4::POSTMATCH()
5458             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5459 6         28 $char[$i] = '@{[Elatin4::POSTMATCH()]}';
5460             }
5461              
5462             # ${ foo } --> ${ foo }
5463             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5464             }
5465              
5466             # ${ ... }
5467             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5468 0         0 $char[$i] = e_capture($1);
5469             }
5470             }
5471              
5472             # return string
5473 78 50       216 if ($left_e > $right_e) {
5474 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5475             }
5476 78         807 return join '', @char;
5477             }
5478              
5479             #
5480             # escape regexp (m//, qr//)
5481             #
5482             sub e_qr {
5483 651     651 0 1896 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5484 651   100     2393 $modifier ||= '';
5485              
5486 651         987 $modifier =~ tr/p//d;
5487 651 50       1729 if ($modifier =~ /([adlu])/oxms) {
5488 0         0 my $line = 0;
5489 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5490 0 0       0 if ($filename ne __FILE__) {
5491 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5492 0         0 last;
5493             }
5494             }
5495 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5496             }
5497              
5498 651         889 $slash = 'div';
5499              
5500             # literal null string pattern
5501 651 100       2162 if ($string eq '') {
    100          
5502 8         10 $modifier =~ tr/bB//d;
5503 8         13 $modifier =~ tr/i//d;
5504 8         65 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5505             }
5506              
5507             # /b /B modifier
5508             elsif ($modifier =~ tr/bB//d) {
5509              
5510             # choice again delimiter
5511 2 50       17 if ($delimiter =~ / [\@:] /oxms) {
5512 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5513 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5514 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5515 0         0 $delimiter = '(';
5516 0         0 $end_delimiter = ')';
5517             }
5518             elsif (not $octet{'}'}) {
5519 0         0 $delimiter = '{';
5520 0         0 $end_delimiter = '}';
5521             }
5522             elsif (not $octet{']'}) {
5523 0         0 $delimiter = '[';
5524 0         0 $end_delimiter = ']';
5525             }
5526             elsif (not $octet{'>'}) {
5527 0         0 $delimiter = '<';
5528 0         0 $end_delimiter = '>';
5529             }
5530             else {
5531 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5532 0 0       0 if (not $octet{$char}) {
5533 0         0 $delimiter = $char;
5534 0         0 $end_delimiter = $char;
5535 0         0 last;
5536             }
5537             }
5538             }
5539             }
5540              
5541 2 50 33     12 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5542 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5543             }
5544             else {
5545 2         11 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5546             }
5547             }
5548              
5549 641 100       1508 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5550 641         2588 my $metachar = qr/[\@\\|[\]{^]/oxms;
5551              
5552             # split regexp
5553 641         72970 my @char = $string =~ /\G((?>
5554             [^\\\$\@\[\(] |
5555             \\x (?>[0-9A-Fa-f]{1,2}) |
5556             \\ (?>[0-7]{2,3}) |
5557             \\c [\x40-\x5F] |
5558             \\x\{ (?>[0-9A-Fa-f]+) \} |
5559             \\o\{ (?>[0-7]+) \} |
5560             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5561             \\ $q_char |
5562             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5563             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5564             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5565             [\$\@] $qq_variable |
5566             \$ (?>\s* [0-9]+) |
5567             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5568             \$ \$ (?![\w\{]) |
5569             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5570             \[\^ |
5571             \[\: (?>[a-z]+) :\] |
5572             \[\:\^ (?>[a-z]+) :\] |
5573             \(\? |
5574             $q_char
5575             ))/oxmsg;
5576              
5577             # choice again delimiter
5578 641 50       3344 if ($delimiter =~ / [\@:] /oxms) {
5579 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5580 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5581 0         0 $delimiter = '(';
5582 0         0 $end_delimiter = ')';
5583             }
5584             elsif (not $octet{'}'}) {
5585 0         0 $delimiter = '{';
5586 0         0 $end_delimiter = '}';
5587             }
5588             elsif (not $octet{']'}) {
5589 0         0 $delimiter = '[';
5590 0         0 $end_delimiter = ']';
5591             }
5592             elsif (not $octet{'>'}) {
5593 0         0 $delimiter = '<';
5594 0         0 $end_delimiter = '>';
5595             }
5596             else {
5597 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5598 0 0       0 if (not $octet{$char}) {
5599 0         0 $delimiter = $char;
5600 0         0 $end_delimiter = $char;
5601 0         0 last;
5602             }
5603             }
5604             }
5605             }
5606              
5607 641         856 my $left_e = 0;
5608 641         767 my $right_e = 0;
5609 641         1873 for (my $i=0; $i <= $#char; $i++) {
5610              
5611             # "\L\u" --> "\u\L"
5612 1867 50 66     12356 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5613 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5614             }
5615              
5616             # "\U\l" --> "\l\U"
5617             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5618 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5619             }
5620              
5621             # octal escape sequence
5622             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5623 1         4 $char[$i] = Elatin4::octchr($1);
5624             }
5625              
5626             # hexadecimal escape sequence
5627             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5628 1         5 $char[$i] = Elatin4::hexchr($1);
5629             }
5630              
5631             # \b{...} --> b\{...}
5632             # \B{...} --> B\{...}
5633             # \N{CHARNAME} --> N\{CHARNAME}
5634             # \p{PROPERTY} --> p\{PROPERTY}
5635             # \P{PROPERTY} --> P\{PROPERTY}
5636             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5637 6         25 $char[$i] = $1 . '\\' . $2;
5638             }
5639              
5640             # \p, \P, \X --> p, P, X
5641             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5642 4         16 $char[$i] = $1;
5643             }
5644              
5645 1867 100 100     6304 if (0) {
    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          
5646             }
5647              
5648             # join separated multiple-octet
5649 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5650 6 50 33     118 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)) {
    50 33        
    50 33        
      33        
      66        
      33        
5651 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
5652             }
5653             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)) {
5654 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
5655             }
5656             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)) {
5657 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
5658             }
5659             }
5660              
5661             # open character class [...]
5662             elsif ($char[$i] eq '[') {
5663 328         407 my $left = $i;
5664              
5665             # [] make die "Unmatched [] in regexp ...\n"
5666             # (and so on)
5667              
5668 328 100       955 if ($char[$i+1] eq ']') {
5669 3         7 $i++;
5670             }
5671              
5672 328         330 while (1) {
5673 1379 50       2039 if (++$i > $#char) {
5674 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5675             }
5676 1379 100       2340 if ($char[$i] eq ']') {
5677 328         365 my $right = $i;
5678              
5679             # [...]
5680 328 100       2011 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5681 30         54 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin4::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         108  
5682             }
5683             else {
5684 298         1360 splice @char, $left, $right-$left+1, Elatin4::charlist_qr(@char[$left+1..$right-1], $modifier);
5685             }
5686              
5687 328         507 $i = $left;
5688 328         957 last;
5689             }
5690             }
5691             }
5692              
5693             # open character class [^...]
5694             elsif ($char[$i] eq '[^') {
5695 74         92 my $left = $i;
5696              
5697             # [^] make die "Unmatched [] in regexp ...\n"
5698             # (and so on)
5699              
5700 74 100       193 if ($char[$i+1] eq ']') {
5701 4         8 $i++;
5702             }
5703              
5704 74         66 while (1) {
5705 272 50       419 if (++$i > $#char) {
5706 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5707             }
5708 272 100       512 if ($char[$i] eq ']') {
5709 74         80 my $right = $i;
5710              
5711             # [^...]
5712 74 100       443 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5713 30         67 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin4::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         120  
5714             }
5715             else {
5716 44         199 splice @char, $left, $right-$left+1, Elatin4::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5717             }
5718              
5719 74         119 $i = $left;
5720 74         227 last;
5721             }
5722             }
5723             }
5724              
5725             # rewrite character class or escape character
5726             elsif (my $char = character_class($char[$i],$modifier)) {
5727 139         593 $char[$i] = $char;
5728             }
5729              
5730             # /i modifier
5731             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin4::uc($char[$i]) ne Elatin4::fc($char[$i]))) {
5732 20 50       33 if (CORE::length(Elatin4::fc($char[$i])) == 1) {
5733 20         50 $char[$i] = '[' . Elatin4::uc($char[$i]) . Elatin4::fc($char[$i]) . ']';
5734             }
5735             else {
5736 0         0 $char[$i] = '(?:' . Elatin4::uc($char[$i]) . '|' . Elatin4::fc($char[$i]) . ')';
5737             }
5738             }
5739              
5740             # \u \l \U \L \F \Q \E
5741             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5742 1 50       6 if ($right_e < $left_e) {
5743 0         0 $char[$i] = '\\' . $char[$i];
5744             }
5745             }
5746             elsif ($char[$i] eq '\u') {
5747 0         0 $char[$i] = '@{[Elatin4::ucfirst qq<';
5748 0         0 $left_e++;
5749             }
5750             elsif ($char[$i] eq '\l') {
5751 0         0 $char[$i] = '@{[Elatin4::lcfirst qq<';
5752 0         0 $left_e++;
5753             }
5754             elsif ($char[$i] eq '\U') {
5755 1         2 $char[$i] = '@{[Elatin4::uc qq<';
5756 1         19 $left_e++;
5757             }
5758             elsif ($char[$i] eq '\L') {
5759 1         3 $char[$i] = '@{[Elatin4::lc qq<';
5760 1         7 $left_e++;
5761             }
5762             elsif ($char[$i] eq '\F') {
5763 18         19 $char[$i] = '@{[Elatin4::fc qq<';
5764 18         77 $left_e++;
5765             }
5766             elsif ($char[$i] eq '\Q') {
5767 1         3 $char[$i] = '@{[CORE::quotemeta qq<';
5768 1         8 $left_e++;
5769             }
5770             elsif ($char[$i] eq '\E') {
5771 21 50       40 if ($right_e < $left_e) {
5772 21         20 $char[$i] = '>]}';
5773 21         77 $right_e++;
5774             }
5775             else {
5776 0         0 $char[$i] = '';
5777             }
5778             }
5779             elsif ($char[$i] eq '\Q') {
5780 0         0 while (1) {
5781 0 0       0 if (++$i > $#char) {
5782 0         0 last;
5783             }
5784 0 0       0 if ($char[$i] eq '\E') {
5785 0         0 last;
5786             }
5787             }
5788             }
5789             elsif ($char[$i] eq '\E') {
5790             }
5791              
5792             # $0 --> $0
5793             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5794 0 0       0 if ($ignorecase) {
5795 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5796             }
5797             }
5798             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5799 0 0       0 if ($ignorecase) {
5800 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5801             }
5802             }
5803              
5804             # $$ --> $$
5805             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5806             }
5807              
5808             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5809             # $1, $2, $3 --> $1, $2, $3 otherwise
5810             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5811 0         0 $char[$i] = e_capture($1);
5812 0 0       0 if ($ignorecase) {
5813 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5814             }
5815             }
5816             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5817 0         0 $char[$i] = e_capture($1);
5818 0 0       0 if ($ignorecase) {
5819 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5820             }
5821             }
5822              
5823             # $$foo[ ... ] --> $ $foo->[ ... ]
5824             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5825 0         0 $char[$i] = e_capture($1.'->'.$2);
5826 0 0       0 if ($ignorecase) {
5827 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5828             }
5829             }
5830              
5831             # $$foo{ ... } --> $ $foo->{ ... }
5832             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5833 0         0 $char[$i] = e_capture($1.'->'.$2);
5834 0 0       0 if ($ignorecase) {
5835 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5836             }
5837             }
5838              
5839             # $$foo
5840             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5841 0         0 $char[$i] = e_capture($1);
5842 0 0       0 if ($ignorecase) {
5843 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5844             }
5845             }
5846              
5847             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin4::PREMATCH()
5848             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5849 8 50       25 if ($ignorecase) {
5850 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::PREMATCH())]}';
5851             }
5852             else {
5853 8         45 $char[$i] = '@{[Elatin4::PREMATCH()]}';
5854             }
5855             }
5856              
5857             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin4::MATCH()
5858             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5859 8 50       23 if ($ignorecase) {
5860 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::MATCH())]}';
5861             }
5862             else {
5863 8         43 $char[$i] = '@{[Elatin4::MATCH()]}';
5864             }
5865             }
5866              
5867             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin4::POSTMATCH()
5868             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5869 6 50       16 if ($ignorecase) {
5870 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::POSTMATCH())]}';
5871             }
5872             else {
5873 6         37 $char[$i] = '@{[Elatin4::POSTMATCH()]}';
5874             }
5875             }
5876              
5877             # ${ foo }
5878             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5879 0 0       0 if ($ignorecase) {
5880 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5881             }
5882             }
5883              
5884             # ${ ... }
5885             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5886 0         0 $char[$i] = e_capture($1);
5887 0 0       0 if ($ignorecase) {
5888 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5889             }
5890             }
5891              
5892             # $scalar or @array
5893             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5894 21         46 $char[$i] = e_string($char[$i]);
5895 21 100       80 if ($ignorecase) {
5896 11         60 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
5897             }
5898             }
5899              
5900             # quote character before ? + * {
5901             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5902 138 100 33     1240 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5903             }
5904             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5905 0         0 my $char = $char[$i-1];
5906 0 0       0 if ($char[$i] eq '{') {
5907 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5908             }
5909             else {
5910 0         0 die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5911             }
5912             }
5913             else {
5914 127         886 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5915             }
5916             }
5917             }
5918              
5919             # make regexp string
5920 641         947 $modifier =~ tr/i//d;
5921 641 50       1414 if ($left_e > $right_e) {
5922 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5923 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5924             }
5925             else {
5926 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5927             }
5928             }
5929 641 50 33     4169 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5930 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5931             }
5932             else {
5933 641         5873 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5934             }
5935             }
5936              
5937             #
5938             # double quote stuff
5939             #
5940             sub qq_stuff {
5941 180     180 0 189 my($delimiter,$end_delimiter,$stuff) = @_;
5942              
5943             # scalar variable or array variable
5944 180 100       356 if ($stuff =~ /\A [\$\@] /oxms) {
5945 100         329 return $stuff;
5946             }
5947              
5948             # quote by delimiter
5949 80         165 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         234  
5950 80         170 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5951 80 50       148 next if $char eq $delimiter;
5952 80 50       110 next if $char eq $end_delimiter;
5953 80 50       135 if (not $octet{$char}) {
5954 80         409 return join '', 'qq', $char, $stuff, $char;
5955             }
5956             }
5957 0         0 return join '', 'qq', '<', $stuff, '>';
5958             }
5959              
5960             #
5961             # escape regexp (m'', qr'', and m''b, qr''b)
5962             #
5963             sub e_qr_q {
5964 10     10 0 38 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5965 10   50     49 $modifier ||= '';
5966              
5967 10         17 $modifier =~ tr/p//d;
5968 10 50       27 if ($modifier =~ /([adlu])/oxms) {
5969 0         0 my $line = 0;
5970 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5971 0 0       0 if ($filename ne __FILE__) {
5972 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5973 0         0 last;
5974             }
5975             }
5976 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5977             }
5978              
5979 10         16 $slash = 'div';
5980              
5981             # literal null string pattern
5982 10 100       32 if ($string eq '') {
    50          
5983 8         11 $modifier =~ tr/bB//d;
5984 8         10 $modifier =~ tr/i//d;
5985 8         53 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5986             }
5987              
5988             # with /b /B modifier
5989             elsif ($modifier =~ tr/bB//d) {
5990 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5991             }
5992              
5993             # without /b /B modifier
5994             else {
5995 2         10 return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5996             }
5997             }
5998              
5999             #
6000             # escape regexp (m'', qr'')
6001             #
6002             sub e_qr_qt {
6003 2     2 0 6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6004              
6005 2 50       8 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6006              
6007             # split regexp
6008 2         133 my @char = $string =~ /\G((?>
6009             [^\\\[\$\@\/] |
6010             [\x00-\xFF] |
6011             \[\^ |
6012             \[\: (?>[a-z]+) \:\] |
6013             \[\:\^ (?>[a-z]+) \:\] |
6014             [\$\@\/] |
6015             \\ (?:$q_char) |
6016             (?:$q_char)
6017             ))/oxmsg;
6018              
6019             # unescape character
6020 2         14 for (my $i=0; $i <= $#char; $i++) {
6021 2 50 33     23 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
6022             }
6023              
6024             # open character class [...]
6025 0         0 elsif ($char[$i] eq '[') {
6026 0         0 my $left = $i;
6027 0 0       0 if ($char[$i+1] eq ']') {
6028 0         0 $i++;
6029             }
6030 0         0 while (1) {
6031 0 0       0 if (++$i > $#char) {
6032 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6033             }
6034 0 0       0 if ($char[$i] eq ']') {
6035 0         0 my $right = $i;
6036              
6037             # [...]
6038 0         0 splice @char, $left, $right-$left+1, Elatin4::charlist_qr(@char[$left+1..$right-1], $modifier);
6039              
6040 0         0 $i = $left;
6041 0         0 last;
6042             }
6043             }
6044             }
6045              
6046             # open character class [^...]
6047             elsif ($char[$i] eq '[^') {
6048 0         0 my $left = $i;
6049 0 0       0 if ($char[$i+1] eq ']') {
6050 0         0 $i++;
6051             }
6052 0         0 while (1) {
6053 0 0       0 if (++$i > $#char) {
6054 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6055             }
6056 0 0       0 if ($char[$i] eq ']') {
6057 0         0 my $right = $i;
6058              
6059             # [^...]
6060 0         0 splice @char, $left, $right-$left+1, Elatin4::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6061              
6062 0         0 $i = $left;
6063 0         0 last;
6064             }
6065             }
6066             }
6067              
6068             # escape $ @ / and \
6069             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6070 0         0 $char[$i] = '\\' . $char[$i];
6071             }
6072              
6073             # rewrite character class or escape character
6074             elsif (my $char = character_class($char[$i],$modifier)) {
6075 0         0 $char[$i] = $char;
6076             }
6077              
6078             # /i modifier
6079             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin4::uc($char[$i]) ne Elatin4::fc($char[$i]))) {
6080 0 0       0 if (CORE::length(Elatin4::fc($char[$i])) == 1) {
6081 0         0 $char[$i] = '[' . Elatin4::uc($char[$i]) . Elatin4::fc($char[$i]) . ']';
6082             }
6083             else {
6084 0         0 $char[$i] = '(?:' . Elatin4::uc($char[$i]) . '|' . Elatin4::fc($char[$i]) . ')';
6085             }
6086             }
6087              
6088             # quote character before ? + * {
6089             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6090 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6091             }
6092             else {
6093 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6094             }
6095             }
6096             }
6097              
6098 2         7 $delimiter = '/';
6099 2         6 $end_delimiter = '/';
6100              
6101 2         4 $modifier =~ tr/i//d;
6102 2         23 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6103             }
6104              
6105             #
6106             # escape regexp (m''b, qr''b)
6107             #
6108             sub e_qr_qb {
6109 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6110              
6111             # split regexp
6112 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6113              
6114             # unescape character
6115 0         0 for (my $i=0; $i <= $#char; $i++) {
6116 0 0       0 if (0) {
    0          
6117             }
6118              
6119             # remain \\
6120 0         0 elsif ($char[$i] eq '\\\\') {
6121             }
6122              
6123             # escape $ @ / and \
6124             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6125 0         0 $char[$i] = '\\' . $char[$i];
6126             }
6127             }
6128              
6129 0         0 $delimiter = '/';
6130 0         0 $end_delimiter = '/';
6131 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6132             }
6133              
6134             #
6135             # escape regexp (s/here//)
6136             #
6137             sub e_s1 {
6138 76     76 0 192 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6139 76   100     297 $modifier ||= '';
6140              
6141 76         115 $modifier =~ tr/p//d;
6142 76 50       229 if ($modifier =~ /([adlu])/oxms) {
6143 0         0 my $line = 0;
6144 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6145 0 0       0 if ($filename ne __FILE__) {
6146 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6147 0         0 last;
6148             }
6149             }
6150 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6151             }
6152              
6153 76         123 $slash = 'div';
6154              
6155             # literal null string pattern
6156 76 100       321 if ($string eq '') {
    50          
6157 8         12 $modifier =~ tr/bB//d;
6158 8         13 $modifier =~ tr/i//d;
6159 8         82 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6160             }
6161              
6162             # /b /B modifier
6163             elsif ($modifier =~ tr/bB//d) {
6164              
6165             # choice again delimiter
6166 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
6167 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6168 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6169 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6170 0         0 $delimiter = '(';
6171 0         0 $end_delimiter = ')';
6172             }
6173             elsif (not $octet{'}'}) {
6174 0         0 $delimiter = '{';
6175 0         0 $end_delimiter = '}';
6176             }
6177             elsif (not $octet{']'}) {
6178 0         0 $delimiter = '[';
6179 0         0 $end_delimiter = ']';
6180             }
6181             elsif (not $octet{'>'}) {
6182 0         0 $delimiter = '<';
6183 0         0 $end_delimiter = '>';
6184             }
6185             else {
6186 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6187 0 0       0 if (not $octet{$char}) {
6188 0         0 $delimiter = $char;
6189 0         0 $end_delimiter = $char;
6190 0         0 last;
6191             }
6192             }
6193             }
6194             }
6195              
6196 0         0 my $prematch = '';
6197 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6198             }
6199              
6200 68 100       184 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6201 68         279 my $metachar = qr/[\@\\|[\]{^]/oxms;
6202              
6203             # split regexp
6204 68         17986 my @char = $string =~ /\G((?>
6205             [^\\\$\@\[\(] |
6206             \\ (?>[1-9][0-9]*) |
6207             \\g (?>\s*) (?>[1-9][0-9]*) |
6208             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6209             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6210             \\x (?>[0-9A-Fa-f]{1,2}) |
6211             \\ (?>[0-7]{2,3}) |
6212             \\c [\x40-\x5F] |
6213             \\x\{ (?>[0-9A-Fa-f]+) \} |
6214             \\o\{ (?>[0-7]+) \} |
6215             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6216             \\ $q_char |
6217             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6218             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6219             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6220             [\$\@] $qq_variable |
6221             \$ (?>\s* [0-9]+) |
6222             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6223             \$ \$ (?![\w\{]) |
6224             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6225             \[\^ |
6226             \[\: (?>[a-z]+) :\] |
6227             \[\:\^ (?>[a-z]+) :\] |
6228             \(\? |
6229             $q_char
6230             ))/oxmsg;
6231              
6232             # choice again delimiter
6233 68 50       576 if ($delimiter =~ / [\@:] /oxms) {
6234 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6235 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6236 0         0 $delimiter = '(';
6237 0         0 $end_delimiter = ')';
6238             }
6239             elsif (not $octet{'}'}) {
6240 0         0 $delimiter = '{';
6241 0         0 $end_delimiter = '}';
6242             }
6243             elsif (not $octet{']'}) {
6244 0         0 $delimiter = '[';
6245 0         0 $end_delimiter = ']';
6246             }
6247             elsif (not $octet{'>'}) {
6248 0         0 $delimiter = '<';
6249 0         0 $end_delimiter = '>';
6250             }
6251             else {
6252 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6253 0 0       0 if (not $octet{$char}) {
6254 0         0 $delimiter = $char;
6255 0         0 $end_delimiter = $char;
6256 0         0 last;
6257             }
6258             }
6259             }
6260             }
6261              
6262             # count '('
6263 68         125 my $parens = grep { $_ eq '(' } @char;
  253         388  
6264              
6265 68         84 my $left_e = 0;
6266 68         84 my $right_e = 0;
6267 68         225 for (my $i=0; $i <= $#char; $i++) {
6268              
6269             # "\L\u" --> "\u\L"
6270 195 50 33     1392 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6271 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6272             }
6273              
6274             # "\U\l" --> "\l\U"
6275             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6276 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6277             }
6278              
6279             # octal escape sequence
6280             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6281 1         2 $char[$i] = Elatin4::octchr($1);
6282             }
6283              
6284             # hexadecimal escape sequence
6285             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6286 1         3 $char[$i] = Elatin4::hexchr($1);
6287             }
6288              
6289             # \b{...} --> b\{...}
6290             # \B{...} --> B\{...}
6291             # \N{CHARNAME} --> N\{CHARNAME}
6292             # \p{PROPERTY} --> p\{PROPERTY}
6293             # \P{PROPERTY} --> P\{PROPERTY}
6294             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6295 0         0 $char[$i] = $1 . '\\' . $2;
6296             }
6297              
6298             # \p, \P, \X --> p, P, X
6299             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6300 0         0 $char[$i] = $1;
6301             }
6302              
6303 195 50 66     794 if (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          
6304             }
6305              
6306             # join separated multiple-octet
6307 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6308 0 0 0     0 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)) {
    0 0        
    0 0        
      0        
      0        
      0        
6309 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
6310             }
6311             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)) {
6312 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
6313             }
6314             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)) {
6315 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
6316             }
6317             }
6318              
6319             # open character class [...]
6320             elsif ($char[$i] eq '[') {
6321 13         20 my $left = $i;
6322 13 50       49 if ($char[$i+1] eq ']') {
6323 0         0 $i++;
6324             }
6325 13         15 while (1) {
6326 58 50       79 if (++$i > $#char) {
6327 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6328             }
6329 58 100       91 if ($char[$i] eq ']') {
6330 13         13 my $right = $i;
6331              
6332             # [...]
6333 13 50       85 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6334 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin4::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6335             }
6336             else {
6337 13         101 splice @char, $left, $right-$left+1, Elatin4::charlist_qr(@char[$left+1..$right-1], $modifier);
6338             }
6339              
6340 13         14 $i = $left;
6341 13         34 last;
6342             }
6343             }
6344             }
6345              
6346             # open character class [^...]
6347             elsif ($char[$i] eq '[^') {
6348 0         0 my $left = $i;
6349 0 0       0 if ($char[$i+1] eq ']') {
6350 0         0 $i++;
6351             }
6352 0         0 while (1) {
6353 0 0       0 if (++$i > $#char) {
6354 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6355             }
6356 0 0       0 if ($char[$i] eq ']') {
6357 0         0 my $right = $i;
6358              
6359             # [^...]
6360 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6361 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin4::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6362             }
6363             else {
6364 0         0 splice @char, $left, $right-$left+1, Elatin4::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6365             }
6366              
6367 0         0 $i = $left;
6368 0         0 last;
6369             }
6370             }
6371             }
6372              
6373             # rewrite character class or escape character
6374             elsif (my $char = character_class($char[$i],$modifier)) {
6375 7         15 $char[$i] = $char;
6376             }
6377              
6378             # /i modifier
6379             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin4::uc($char[$i]) ne Elatin4::fc($char[$i]))) {
6380 3 50       13 if (CORE::length(Elatin4::fc($char[$i])) == 1) {
6381 3         6 $char[$i] = '[' . Elatin4::uc($char[$i]) . Elatin4::fc($char[$i]) . ']';
6382             }
6383             else {
6384 0         0 $char[$i] = '(?:' . Elatin4::uc($char[$i]) . '|' . Elatin4::fc($char[$i]) . ')';
6385             }
6386             }
6387              
6388             # \u \l \U \L \F \Q \E
6389             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6390 0 0       0 if ($right_e < $left_e) {
6391 0         0 $char[$i] = '\\' . $char[$i];
6392             }
6393             }
6394             elsif ($char[$i] eq '\u') {
6395 0         0 $char[$i] = '@{[Elatin4::ucfirst qq<';
6396 0         0 $left_e++;
6397             }
6398             elsif ($char[$i] eq '\l') {
6399 0         0 $char[$i] = '@{[Elatin4::lcfirst qq<';
6400 0         0 $left_e++;
6401             }
6402             elsif ($char[$i] eq '\U') {
6403 0         0 $char[$i] = '@{[Elatin4::uc qq<';
6404 0         0 $left_e++;
6405             }
6406             elsif ($char[$i] eq '\L') {
6407 0         0 $char[$i] = '@{[Elatin4::lc qq<';
6408 0         0 $left_e++;
6409             }
6410             elsif ($char[$i] eq '\F') {
6411 0         0 $char[$i] = '@{[Elatin4::fc qq<';
6412 0         0 $left_e++;
6413             }
6414             elsif ($char[$i] eq '\Q') {
6415 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6416 0         0 $left_e++;
6417             }
6418             elsif ($char[$i] eq '\E') {
6419 0 0       0 if ($right_e < $left_e) {
6420 0         0 $char[$i] = '>]}';
6421 0         0 $right_e++;
6422             }
6423             else {
6424 0         0 $char[$i] = '';
6425             }
6426             }
6427             elsif ($char[$i] eq '\Q') {
6428 0         0 while (1) {
6429 0 0       0 if (++$i > $#char) {
6430 0         0 last;
6431             }
6432 0 0       0 if ($char[$i] eq '\E') {
6433 0         0 last;
6434             }
6435             }
6436             }
6437             elsif ($char[$i] eq '\E') {
6438             }
6439              
6440             # \0 --> \0
6441             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6442             }
6443              
6444             # \g{N}, \g{-N}
6445              
6446             # P.108 Using Simple Patterns
6447             # in Chapter 7: In the World of Regular Expressions
6448             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6449              
6450             # P.221 Capturing
6451             # in Chapter 5: Pattern Matching
6452             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6453              
6454             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6455             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6456             }
6457              
6458             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6459             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6460             }
6461              
6462             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6463             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6464             }
6465              
6466             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6467             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6468             }
6469              
6470             # $0 --> $0
6471             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6472 0 0       0 if ($ignorecase) {
6473 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6474             }
6475             }
6476             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6477 0 0       0 if ($ignorecase) {
6478 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6479             }
6480             }
6481              
6482             # $$ --> $$
6483             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6484             }
6485              
6486             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6487             # $1, $2, $3 --> $1, $2, $3 otherwise
6488             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6489 0         0 $char[$i] = e_capture($1);
6490 0 0       0 if ($ignorecase) {
6491 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6492             }
6493             }
6494             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6495 0         0 $char[$i] = e_capture($1);
6496 0 0       0 if ($ignorecase) {
6497 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6498             }
6499             }
6500              
6501             # $$foo[ ... ] --> $ $foo->[ ... ]
6502             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6503 0         0 $char[$i] = e_capture($1.'->'.$2);
6504 0 0       0 if ($ignorecase) {
6505 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6506             }
6507             }
6508              
6509             # $$foo{ ... } --> $ $foo->{ ... }
6510             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6511 0         0 $char[$i] = e_capture($1.'->'.$2);
6512 0 0       0 if ($ignorecase) {
6513 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6514             }
6515             }
6516              
6517             # $$foo
6518             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6519 0         0 $char[$i] = e_capture($1);
6520 0 0       0 if ($ignorecase) {
6521 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6522             }
6523             }
6524              
6525             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin4::PREMATCH()
6526             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6527 4 50       15 if ($ignorecase) {
6528 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::PREMATCH())]}';
6529             }
6530             else {
6531 4         26 $char[$i] = '@{[Elatin4::PREMATCH()]}';
6532             }
6533             }
6534              
6535             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin4::MATCH()
6536             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6537 4 50       13 if ($ignorecase) {
6538 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::MATCH())]}';
6539             }
6540             else {
6541 4         23 $char[$i] = '@{[Elatin4::MATCH()]}';
6542             }
6543             }
6544              
6545             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin4::POSTMATCH()
6546             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6547 3 50       11 if ($ignorecase) {
6548 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::POSTMATCH())]}';
6549             }
6550             else {
6551 3         17 $char[$i] = '@{[Elatin4::POSTMATCH()]}';
6552             }
6553             }
6554              
6555             # ${ foo }
6556             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6557 0 0       0 if ($ignorecase) {
6558 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6559             }
6560             }
6561              
6562             # ${ ... }
6563             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6564 0         0 $char[$i] = e_capture($1);
6565 0 0       0 if ($ignorecase) {
6566 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6567             }
6568             }
6569              
6570             # $scalar or @array
6571             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6572 4         14 $char[$i] = e_string($char[$i]);
6573 4 50       46 if ($ignorecase) {
6574 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
6575             }
6576             }
6577              
6578             # quote character before ? + * {
6579             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6580 13 50       57 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6581             }
6582             else {
6583 13         88 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6584             }
6585             }
6586             }
6587              
6588             # make regexp string
6589 68         134 my $prematch = '';
6590 68         108 $modifier =~ tr/i//d;
6591 68 50       217 if ($left_e > $right_e) {
6592 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6593             }
6594 68         899 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6595             }
6596              
6597             #
6598             # escape regexp (s'here'' or s'here''b)
6599             #
6600             sub e_s1_q {
6601 21     21 0 47 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6602 21   100     80 $modifier ||= '';
6603              
6604 21         23 $modifier =~ tr/p//d;
6605 21 50       58 if ($modifier =~ /([adlu])/oxms) {
6606 0         0 my $line = 0;
6607 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6608 0 0       0 if ($filename ne __FILE__) {
6609 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6610 0         0 last;
6611             }
6612             }
6613 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6614             }
6615              
6616 21         29 $slash = 'div';
6617              
6618             # literal null string pattern
6619 21 100       69 if ($string eq '') {
    50          
6620 8         9 $modifier =~ tr/bB//d;
6621 8         13 $modifier =~ tr/i//d;
6622 8         66 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6623             }
6624              
6625             # with /b /B modifier
6626             elsif ($modifier =~ tr/bB//d) {
6627 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6628             }
6629              
6630             # without /b /B modifier
6631             else {
6632 13         37 return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6633             }
6634             }
6635              
6636             #
6637             # escape regexp (s'here'')
6638             #
6639             sub e_s1_qt {
6640 13     13 0 25 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6641              
6642 13 50       36 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6643              
6644             # split regexp
6645 13         329 my @char = $string =~ /\G((?>
6646             [^\\\[\$\@\/] |
6647             [\x00-\xFF] |
6648             \[\^ |
6649             \[\: (?>[a-z]+) \:\] |
6650             \[\:\^ (?>[a-z]+) \:\] |
6651             [\$\@\/] |
6652             \\ (?:$q_char) |
6653             (?:$q_char)
6654             ))/oxmsg;
6655              
6656             # unescape character
6657 13         73 for (my $i=0; $i <= $#char; $i++) {
6658 25 50 33     137 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6659             }
6660              
6661             # open character class [...]
6662 0         0 elsif ($char[$i] eq '[') {
6663 0         0 my $left = $i;
6664 0 0       0 if ($char[$i+1] eq ']') {
6665 0         0 $i++;
6666             }
6667 0         0 while (1) {
6668 0 0       0 if (++$i > $#char) {
6669 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6670             }
6671 0 0       0 if ($char[$i] eq ']') {
6672 0         0 my $right = $i;
6673              
6674             # [...]
6675 0         0 splice @char, $left, $right-$left+1, Elatin4::charlist_qr(@char[$left+1..$right-1], $modifier);
6676              
6677 0         0 $i = $left;
6678 0         0 last;
6679             }
6680             }
6681             }
6682              
6683             # open character class [^...]
6684             elsif ($char[$i] eq '[^') {
6685 0         0 my $left = $i;
6686 0 0       0 if ($char[$i+1] eq ']') {
6687 0         0 $i++;
6688             }
6689 0         0 while (1) {
6690 0 0       0 if (++$i > $#char) {
6691 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6692             }
6693 0 0       0 if ($char[$i] eq ']') {
6694 0         0 my $right = $i;
6695              
6696             # [^...]
6697 0         0 splice @char, $left, $right-$left+1, Elatin4::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6698              
6699 0         0 $i = $left;
6700 0         0 last;
6701             }
6702             }
6703             }
6704              
6705             # escape $ @ / and \
6706             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6707 0         0 $char[$i] = '\\' . $char[$i];
6708             }
6709              
6710             # rewrite character class or escape character
6711             elsif (my $char = character_class($char[$i],$modifier)) {
6712 6         14 $char[$i] = $char;
6713             }
6714              
6715             # /i modifier
6716             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin4::uc($char[$i]) ne Elatin4::fc($char[$i]))) {
6717 0 0       0 if (CORE::length(Elatin4::fc($char[$i])) == 1) {
6718 0         0 $char[$i] = '[' . Elatin4::uc($char[$i]) . Elatin4::fc($char[$i]) . ']';
6719             }
6720             else {
6721 0         0 $char[$i] = '(?:' . Elatin4::uc($char[$i]) . '|' . Elatin4::fc($char[$i]) . ')';
6722             }
6723             }
6724              
6725             # quote character before ? + * {
6726             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6727 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6728             }
6729             else {
6730 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6731             }
6732             }
6733             }
6734              
6735 13         18 $modifier =~ tr/i//d;
6736 13         16 $delimiter = '/';
6737 13         18 $end_delimiter = '/';
6738 13         19 my $prematch = '';
6739 13         110 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6740             }
6741              
6742             #
6743             # escape regexp (s'here''b)
6744             #
6745             sub e_s1_qb {
6746 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6747              
6748             # split regexp
6749 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6750              
6751             # unescape character
6752 0         0 for (my $i=0; $i <= $#char; $i++) {
6753 0 0       0 if (0) {
    0          
6754             }
6755              
6756             # remain \\
6757 0         0 elsif ($char[$i] eq '\\\\') {
6758             }
6759              
6760             # escape $ @ / and \
6761             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6762 0         0 $char[$i] = '\\' . $char[$i];
6763             }
6764             }
6765              
6766 0         0 $delimiter = '/';
6767 0         0 $end_delimiter = '/';
6768 0         0 my $prematch = '';
6769 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6770             }
6771              
6772             #
6773             # escape regexp (s''here')
6774             #
6775             sub e_s2_q {
6776 16     16 0 29 my($ope,$delimiter,$end_delimiter,$string) = @_;
6777              
6778 16         40 $slash = 'div';
6779              
6780 16         140 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6781 16         57 for (my $i=0; $i <= $#char; $i++) {
6782 9 100       42 if (0) {
    100          
6783             }
6784              
6785             # not escape \\
6786 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6787             }
6788              
6789             # escape $ @ / and \
6790             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6791 5         20 $char[$i] = '\\' . $char[$i];
6792             }
6793             }
6794              
6795 16         55 return join '', $ope, $delimiter, @char, $end_delimiter;
6796             }
6797              
6798             #
6799             # escape regexp (s/here/and here/modifier)
6800             #
6801             sub e_sub {
6802 97     97 0 547 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6803 97   100     440 $modifier ||= '';
6804              
6805 97         193 $modifier =~ tr/p//d;
6806 97 50       343 if ($modifier =~ /([adlu])/oxms) {
6807 0         0 my $line = 0;
6808 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6809 0 0       0 if ($filename ne __FILE__) {
6810 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6811 0         0 last;
6812             }
6813             }
6814 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6815             }
6816              
6817 97 100       296 if ($variable eq '') {
6818 36         47 $variable = '$_';
6819 36         51 $bind_operator = ' =~ ';
6820             }
6821              
6822 97         145 $slash = 'div';
6823              
6824             # P.128 Start of match (or end of previous match): \G
6825             # P.130 Advanced Use of \G with Perl
6826             # in Chapter 3: Overview of Regular Expression Features and Flavors
6827             # P.312 Iterative Matching: Scalar Context, with /g
6828             # in Chapter 7: Perl
6829             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6830              
6831             # P.181 Where You Left Off: The \G Assertion
6832             # in Chapter 5: Pattern Matching
6833             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6834              
6835             # P.220 Where You Left Off: The \G Assertion
6836             # in Chapter 5: Pattern Matching
6837             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6838              
6839 97         147 my $e_modifier = $modifier =~ tr/e//d;
6840 97         138 my $r_modifier = $modifier =~ tr/r//d;
6841              
6842 97         128 my $my = '';
6843 97 50       274 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6844 0         0 $my = $variable;
6845 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6846 0         0 $variable =~ s/ = .+ \z//oxms;
6847             }
6848              
6849 97         248 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6850 97         170 $variable_basename =~ s/ \s+ \z//oxms;
6851              
6852             # quote replacement string
6853 97         135 my $e_replacement = '';
6854 97 100       229 if ($e_modifier >= 1) {
6855 17         37 $e_replacement = e_qq('', '', '', $replacement);
6856 17         26 $e_modifier--;
6857             }
6858             else {
6859 80 100       221 if ($delimiter2 eq "'") {
6860 16         40 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6861             }
6862             else {
6863 64         158 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6864             }
6865             }
6866              
6867 97         152 my $sub = '';
6868              
6869             # with /r
6870 97 100       216 if ($r_modifier) {
6871 8 100       18 if (0) {
6872             }
6873              
6874             # s///gr without multibyte anchoring
6875 0         0 elsif ($modifier =~ /g/oxms) {
6876 4 50       13 $sub = sprintf(
6877             # 1 2 3 4 5
6878             q,
6879              
6880             $variable, # 1
6881             ($delimiter1 eq "'") ? # 2
6882             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6883             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6884             $s_matched, # 3
6885             $e_replacement, # 4
6886             '$Latin4::re_r=CORE::eval $Latin4::re_r; ' x $e_modifier, # 5
6887             );
6888             }
6889              
6890             # s///r
6891             else {
6892              
6893 4         3 my $prematch = q{$`};
6894              
6895 4 50       16 $sub = sprintf(
6896             # 1 2 3 4 5 6 7
6897             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin4::re_r=%s; %s"%s$Latin4::re_r$'" } : %s>,
6898              
6899             $variable, # 1
6900             ($delimiter1 eq "'") ? # 2
6901             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6902             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6903             $s_matched, # 3
6904             $e_replacement, # 4
6905             '$Latin4::re_r=CORE::eval $Latin4::re_r; ' x $e_modifier, # 5
6906             $prematch, # 6
6907             $variable, # 7
6908             );
6909             }
6910              
6911             # $var !~ s///r doesn't make sense
6912 8 50       19 if ($bind_operator =~ / !~ /oxms) {
6913 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6914             }
6915             }
6916              
6917             # without /r
6918             else {
6919 89 100       232 if (0) {
6920             }
6921              
6922             # s///g without multibyte anchoring
6923 0         0 elsif ($modifier =~ /g/oxms) {
6924 22 100       95 $sub = sprintf(
    100          
6925             # 1 2 3 4 5 6 7 8
6926             q,
6927              
6928             $variable, # 1
6929             ($delimiter1 eq "'") ? # 2
6930             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6931             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6932             $s_matched, # 3
6933             $e_replacement, # 4
6934             '$Latin4::re_r=CORE::eval $Latin4::re_r; ' x $e_modifier, # 5
6935             $variable, # 6
6936             $variable, # 7
6937             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6938             );
6939             }
6940              
6941             # s///
6942             else {
6943              
6944 67         125 my $prematch = q{$`};
6945              
6946 67 100       476 $sub = sprintf(
    100          
6947              
6948             ($bind_operator =~ / =~ /oxms) ?
6949              
6950             # 1 2 3 4 5 6 7 8
6951             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin4::re_r=%s; %s%s="%s$Latin4::re_r$'"; 1 } : undef> :
6952              
6953             # 1 2 3 4 5 6 7 8
6954             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin4::re_r=%s; %s%s="%s$Latin4::re_r$'"; undef }>,
6955              
6956             $variable, # 1
6957             $bind_operator, # 2
6958             ($delimiter1 eq "'") ? # 3
6959             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6960             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6961             $s_matched, # 4
6962             $e_replacement, # 5
6963             '$Latin4::re_r=CORE::eval $Latin4::re_r; ' x $e_modifier, # 6
6964             $variable, # 7
6965             $prematch, # 8
6966             );
6967             }
6968             }
6969              
6970             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6971 97 50       283 if ($my ne '') {
6972 0         0 $sub = "($my, $sub)[1]";
6973             }
6974              
6975             # clear s/// variable
6976 97         151 $sub_variable = '';
6977 97         129 $bind_operator = '';
6978              
6979 97         768 return $sub;
6980             }
6981              
6982             #
6983             # escape regexp of split qr//
6984             #
6985             sub e_split {
6986 74     74 0 271 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6987 74   100     392 $modifier ||= '';
6988              
6989 74         121 $modifier =~ tr/p//d;
6990 74 50       346 if ($modifier =~ /([adlu])/oxms) {
6991 0         0 my $line = 0;
6992 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6993 0 0       0 if ($filename ne __FILE__) {
6994 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6995 0         0 last;
6996             }
6997             }
6998 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6999             }
7000              
7001 74         133 $slash = 'div';
7002              
7003             # /b /B modifier
7004 74 50       174 if ($modifier =~ tr/bB//d) {
7005 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7006             }
7007              
7008 74 50       191 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7009 74         322 my $metachar = qr/[\@\\|[\]{^]/oxms;
7010              
7011             # split regexp
7012 74         11493 my @char = $string =~ /\G((?>
7013             [^\\\$\@\[\(] |
7014             \\x (?>[0-9A-Fa-f]{1,2}) |
7015             \\ (?>[0-7]{2,3}) |
7016             \\c [\x40-\x5F] |
7017             \\x\{ (?>[0-9A-Fa-f]+) \} |
7018             \\o\{ (?>[0-7]+) \} |
7019             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7020             \\ $q_char |
7021             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7022             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7023             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7024             [\$\@] $qq_variable |
7025             \$ (?>\s* [0-9]+) |
7026             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7027             \$ \$ (?![\w\{]) |
7028             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7029             \[\^ |
7030             \[\: (?>[a-z]+) :\] |
7031             \[\:\^ (?>[a-z]+) :\] |
7032             \(\? |
7033             $q_char
7034             ))/oxmsg;
7035              
7036 74         286 my $left_e = 0;
7037 74         106 my $right_e = 0;
7038 74         367 for (my $i=0; $i <= $#char; $i++) {
7039              
7040             # "\L\u" --> "\u\L"
7041 249 50 33     1638 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7042 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7043             }
7044              
7045             # "\U\l" --> "\l\U"
7046             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7047 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7048             }
7049              
7050             # octal escape sequence
7051             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7052 1         2 $char[$i] = Elatin4::octchr($1);
7053             }
7054              
7055             # hexadecimal escape sequence
7056             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7057 1         4 $char[$i] = Elatin4::hexchr($1);
7058             }
7059              
7060             # \b{...} --> b\{...}
7061             # \B{...} --> B\{...}
7062             # \N{CHARNAME} --> N\{CHARNAME}
7063             # \p{PROPERTY} --> p\{PROPERTY}
7064             # \P{PROPERTY} --> P\{PROPERTY}
7065             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7066 0         0 $char[$i] = $1 . '\\' . $2;
7067             }
7068              
7069             # \p, \P, \X --> p, P, X
7070             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7071 0         0 $char[$i] = $1;
7072             }
7073              
7074 249 50 100     915 if (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          
7075             }
7076              
7077             # join separated multiple-octet
7078 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7079 0 0 0     0 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)) {
    0 0        
    0 0        
      0        
      0        
      0        
7080 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
7081             }
7082             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)) {
7083 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
7084             }
7085             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)) {
7086 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
7087             }
7088             }
7089              
7090             # open character class [...]
7091             elsif ($char[$i] eq '[') {
7092 3         7 my $left = $i;
7093 3 50       11 if ($char[$i+1] eq ']') {
7094 0         0 $i++;
7095             }
7096 3         4 while (1) {
7097 7 50       24 if (++$i > $#char) {
7098 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7099             }
7100 7 100       12 if ($char[$i] eq ']') {
7101 3         5 my $right = $i;
7102              
7103             # [...]
7104 3 50       23 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7105 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin4::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7106             }
7107             else {
7108 3         18 splice @char, $left, $right-$left+1, Elatin4::charlist_qr(@char[$left+1..$right-1], $modifier);
7109             }
7110              
7111 3         3 $i = $left;
7112 3         8 last;
7113             }
7114             }
7115             }
7116              
7117             # open character class [^...]
7118             elsif ($char[$i] eq '[^') {
7119 0         0 my $left = $i;
7120 0 0       0 if ($char[$i+1] eq ']') {
7121 0         0 $i++;
7122             }
7123 0         0 while (1) {
7124 0 0       0 if (++$i > $#char) {
7125 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7126             }
7127 0 0       0 if ($char[$i] eq ']') {
7128 0         0 my $right = $i;
7129              
7130             # [^...]
7131 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7132 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin4::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7133             }
7134             else {
7135 0         0 splice @char, $left, $right-$left+1, Elatin4::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7136             }
7137              
7138 0         0 $i = $left;
7139 0         0 last;
7140             }
7141             }
7142             }
7143              
7144             # rewrite character class or escape character
7145             elsif (my $char = character_class($char[$i],$modifier)) {
7146 1         3 $char[$i] = $char;
7147             }
7148              
7149             # P.794 29.2.161. split
7150             # in Chapter 29: Functions
7151             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7152              
7153             # P.951 split
7154             # in Chapter 27: Functions
7155             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7156              
7157             # said "The //m modifier is assumed when you split on the pattern /^/",
7158             # but perl5.008 is not so. Therefore, this software adds //m.
7159             # (and so on)
7160              
7161             # split(m/^/) --> split(m/^/m)
7162             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7163 7         40 $modifier .= 'm';
7164             }
7165              
7166             # /i modifier
7167             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin4::uc($char[$i]) ne Elatin4::fc($char[$i]))) {
7168 0 0       0 if (CORE::length(Elatin4::fc($char[$i])) == 1) {
7169 0         0 $char[$i] = '[' . Elatin4::uc($char[$i]) . Elatin4::fc($char[$i]) . ']';
7170             }
7171             else {
7172 0         0 $char[$i] = '(?:' . Elatin4::uc($char[$i]) . '|' . Elatin4::fc($char[$i]) . ')';
7173             }
7174             }
7175              
7176             # \u \l \U \L \F \Q \E
7177             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7178 0 0       0 if ($right_e < $left_e) {
7179 0         0 $char[$i] = '\\' . $char[$i];
7180             }
7181             }
7182             elsif ($char[$i] eq '\u') {
7183 0         0 $char[$i] = '@{[Elatin4::ucfirst qq<';
7184 0         0 $left_e++;
7185             }
7186             elsif ($char[$i] eq '\l') {
7187 0         0 $char[$i] = '@{[Elatin4::lcfirst qq<';
7188 0         0 $left_e++;
7189             }
7190             elsif ($char[$i] eq '\U') {
7191 0         0 $char[$i] = '@{[Elatin4::uc qq<';
7192 0         0 $left_e++;
7193             }
7194             elsif ($char[$i] eq '\L') {
7195 0         0 $char[$i] = '@{[Elatin4::lc qq<';
7196 0         0 $left_e++;
7197             }
7198             elsif ($char[$i] eq '\F') {
7199 0         0 $char[$i] = '@{[Elatin4::fc qq<';
7200 0         0 $left_e++;
7201             }
7202             elsif ($char[$i] eq '\Q') {
7203 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7204 0         0 $left_e++;
7205             }
7206             elsif ($char[$i] eq '\E') {
7207 0 0       0 if ($right_e < $left_e) {
7208 0         0 $char[$i] = '>]}';
7209 0         0 $right_e++;
7210             }
7211             else {
7212 0         0 $char[$i] = '';
7213             }
7214             }
7215             elsif ($char[$i] eq '\Q') {
7216 0         0 while (1) {
7217 0 0       0 if (++$i > $#char) {
7218 0         0 last;
7219             }
7220 0 0       0 if ($char[$i] eq '\E') {
7221 0         0 last;
7222             }
7223             }
7224             }
7225             elsif ($char[$i] eq '\E') {
7226             }
7227              
7228             # $0 --> $0
7229             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7230 0 0       0 if ($ignorecase) {
7231 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7232             }
7233             }
7234             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7235 0 0       0 if ($ignorecase) {
7236 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7237             }
7238             }
7239              
7240             # $$ --> $$
7241             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7242             }
7243              
7244             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7245             # $1, $2, $3 --> $1, $2, $3 otherwise
7246             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7247 0         0 $char[$i] = e_capture($1);
7248 0 0       0 if ($ignorecase) {
7249 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7250             }
7251             }
7252             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7253 0         0 $char[$i] = e_capture($1);
7254 0 0       0 if ($ignorecase) {
7255 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7256             }
7257             }
7258              
7259             # $$foo[ ... ] --> $ $foo->[ ... ]
7260             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7261 0         0 $char[$i] = e_capture($1.'->'.$2);
7262 0 0       0 if ($ignorecase) {
7263 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7264             }
7265             }
7266              
7267             # $$foo{ ... } --> $ $foo->{ ... }
7268             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7269 0         0 $char[$i] = e_capture($1.'->'.$2);
7270 0 0       0 if ($ignorecase) {
7271 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7272             }
7273             }
7274              
7275             # $$foo
7276             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7277 0         0 $char[$i] = e_capture($1);
7278 0 0       0 if ($ignorecase) {
7279 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7280             }
7281             }
7282              
7283             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin4::PREMATCH()
7284             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7285 12 50       29 if ($ignorecase) {
7286 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::PREMATCH())]}';
7287             }
7288             else {
7289 12         99 $char[$i] = '@{[Elatin4::PREMATCH()]}';
7290             }
7291             }
7292              
7293             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin4::MATCH()
7294             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7295 12 50       27 if ($ignorecase) {
7296 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::MATCH())]}';
7297             }
7298             else {
7299 12         91 $char[$i] = '@{[Elatin4::MATCH()]}';
7300             }
7301             }
7302              
7303             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin4::POSTMATCH()
7304             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7305 9 50       18 if ($ignorecase) {
7306 0         0 $char[$i] = '@{[Elatin4::ignorecase(Elatin4::POSTMATCH())]}';
7307             }
7308             else {
7309 9         83 $char[$i] = '@{[Elatin4::POSTMATCH()]}';
7310             }
7311             }
7312              
7313             # ${ foo }
7314             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7315 0 0       0 if ($ignorecase) {
7316 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $1 . ')]}';
7317             }
7318             }
7319              
7320             # ${ ... }
7321             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7322 0         0 $char[$i] = e_capture($1);
7323 0 0       0 if ($ignorecase) {
7324 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7325             }
7326             }
7327              
7328             # $scalar or @array
7329             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7330 3         11 $char[$i] = e_string($char[$i]);
7331 3 50       32 if ($ignorecase) {
7332 0         0 $char[$i] = '@{[Elatin4::ignorecase(' . $char[$i] . ')]}';
7333             }
7334             }
7335              
7336             # quote character before ? + * {
7337             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7338 1 50       12 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7339             }
7340             else {
7341 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7342             }
7343             }
7344             }
7345              
7346             # make regexp string
7347 74         150 $modifier =~ tr/i//d;
7348 74 50       197 if ($left_e > $right_e) {
7349 0         0 return join '', 'Elatin4::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7350             }
7351 74         845 return join '', 'Elatin4::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7352             }
7353              
7354             #
7355             # escape regexp of split qr''
7356             #
7357             sub e_split_q {
7358 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7359 0   0       $modifier ||= '';
7360              
7361 0           $modifier =~ tr/p//d;
7362 0 0         if ($modifier =~ /([adlu])/oxms) {
7363 0           my $line = 0;
7364 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7365 0 0         if ($filename ne __FILE__) {
7366 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7367 0           last;
7368             }
7369             }
7370 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7371             }
7372              
7373 0           $slash = 'div';
7374              
7375             # /b /B modifier
7376 0 0         if ($modifier =~ tr/bB//d) {
7377 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7378             }
7379              
7380 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7381              
7382             # split regexp
7383 0           my @char = $string =~ /\G((?>
7384             [^\\\[] |
7385             [\x00-\xFF] |
7386             \[\^ |
7387             \[\: (?>[a-z]+) \:\] |
7388             \[\:\^ (?>[a-z]+) \:\] |
7389             \\ (?:$q_char) |
7390             (?:$q_char)
7391             ))/oxmsg;
7392              
7393             # unescape character
7394 0           for (my $i=0; $i <= $#char; $i++) {
7395 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7396             }
7397              
7398             # open character class [...]
7399 0           elsif ($char[$i] eq '[') {
7400 0           my $left = $i;
7401 0 0         if ($char[$i+1] eq ']') {
7402 0           $i++;
7403             }
7404 0           while (1) {
7405 0 0         if (++$i > $#char) {
7406 0           die __FILE__, ": Unmatched [] in regexp\n";
7407             }
7408 0 0         if ($char[$i] eq ']') {
7409 0           my $right = $i;
7410              
7411             # [...]
7412 0           splice @char, $left, $right-$left+1, Elatin4::charlist_qr(@char[$left+1..$right-1], $modifier);
7413              
7414 0           $i = $left;
7415 0           last;
7416             }
7417             }
7418             }
7419              
7420             # open character class [^...]
7421             elsif ($char[$i] eq '[^') {
7422 0           my $left = $i;
7423 0 0         if ($char[$i+1] eq ']') {
7424 0           $i++;
7425             }
7426 0           while (1) {
7427 0 0         if (++$i > $#char) {
7428 0           die __FILE__, ": Unmatched [] in regexp\n";
7429             }
7430 0 0         if ($char[$i] eq ']') {
7431 0           my $right = $i;
7432              
7433             # [^...]
7434 0           splice @char, $left, $right-$left+1, Elatin4::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7435              
7436 0           $i = $left;
7437 0           last;
7438             }
7439             }
7440             }
7441              
7442             # rewrite character class or escape character
7443             elsif (my $char = character_class($char[$i],$modifier)) {
7444 0           $char[$i] = $char;
7445             }
7446              
7447             # split(m/^/) --> split(m/^/m)
7448             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7449 0           $modifier .= 'm';
7450             }
7451              
7452             # /i modifier
7453             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin4::uc($char[$i]) ne Elatin4::fc($char[$i]))) {
7454 0 0         if (CORE::length(Elatin4::fc($char[$i])) == 1) {
7455 0           $char[$i] = '[' . Elatin4::uc($char[$i]) . Elatin4::fc($char[$i]) . ']';
7456             }
7457             else {
7458 0           $char[$i] = '(?:' . Elatin4::uc($char[$i]) . '|' . Elatin4::fc($char[$i]) . ')';
7459             }
7460             }
7461              
7462             # quote character before ? + * {
7463             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7464 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7465             }
7466             else {
7467 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7468             }
7469             }
7470             }
7471              
7472 0           $modifier =~ tr/i//d;
7473 0           return join '', 'Elatin4::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7474             }
7475              
7476             #
7477             # instead of Carp::carp
7478             #
7479             sub carp {
7480 0     0 0   my($package,$filename,$line) = caller(1);
7481 0           print STDERR "@_ at $filename line $line.\n";
7482             }
7483              
7484             #
7485             # instead of Carp::croak
7486             #
7487             sub croak {
7488 0     0 0   my($package,$filename,$line) = caller(1);
7489 0           print STDERR "@_ at $filename line $line.\n";
7490 0           die "\n";
7491             }
7492              
7493             #
7494             # instead of Carp::cluck
7495             #
7496             sub cluck {
7497 0     0 0   my $i = 0;
7498 0           my @cluck = ();
7499 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7500 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7501 0           $i++;
7502             }
7503 0           print STDERR CORE::reverse @cluck;
7504 0           print STDERR "\n";
7505 0           carp @_;
7506             }
7507              
7508             #
7509             # instead of Carp::confess
7510             #
7511             sub confess {
7512 0     0 0   my $i = 0;
7513 0           my @confess = ();
7514 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7515 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7516 0           $i++;
7517             }
7518 0           print STDERR CORE::reverse @confess;
7519 0           print STDERR "\n";
7520 0           croak @_;
7521             }
7522              
7523             1;
7524              
7525             __END__