File Coverage

blib/lib/Elatin5.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 Elatin5;
2             ######################################################################
3             #
4             # Elatin5 - Run-time routines for Latin5.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin5/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   3421 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         576  
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   12559 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1195  
  200         297  
  200         28209  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1142 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         26973 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   12498 CORE::eval q{
  200     200   999  
  200     66   310  
  200         23409  
  56         4760  
  51         4558  
  37         3497  
  56         5565  
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       104256 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   628 my $genpkg = "Symbol::";
67 200         8960 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) && (Elatin5::index($name, '::') == -1) && (Elatin5::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   363 if (CORE::eval { local $@; CORE::require strict }) {
  200         330  
  200         2211  
115 200         35590 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   13849 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1014  
  200         264  
  200         11370  
145 200     200   11887 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   1141  
  200         292  
  200         15104  
146 200     200   11416 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   918  
  200         280  
  200         13365  
147              
148             #
149             # Latin-5 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   11740 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   918  
  200         276  
  200         323638  
157              
158             #
159             # Latin-5 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 Elatin5 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-9 | iec[- ]?8859-9 | latin-?5 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
183             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
184             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
185             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
186             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
187             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
188             "\xC6" => "\xE6", # LATIN LETTER AE
189             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
190             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
191             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
192             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
193             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
194             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
195             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
196             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
197             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
198             "\xD0" => "\xF0", # LATIN LETTER G WITH BREVE
199             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
200             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
201             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
202             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
203             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
204             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
205             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
206             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
207             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
208             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
209             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
210             "\xDE" => "\xFE", # LATIN LETTER S WITH CEDILLA
211             );
212              
213             %uc = (%uc,
214             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
215             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
216             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
217             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
218             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
219             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
220             "\xE6" => "\xC6", # LATIN LETTER AE
221             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
222             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
223             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
224             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
225             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
226             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
227             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
228             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
229             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
230             "\xF0" => "\xD0", # LATIN LETTER G WITH BREVE
231             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
232             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
233             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
234             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
235             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
236             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
237             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
238             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
239             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
240             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
241             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
242             "\xFE" => "\xDE", # LATIN LETTER S WITH CEDILLA
243             );
244              
245             %fc = (%fc,
246             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
247             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
248             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
249             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
250             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
251             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
252             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
253             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
254             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
255             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
256             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
257             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
258             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
259             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
260             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
261             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
262             "\xD0" => "\xF0", # LATIN CAPITAL LETTER G WITH BREVE --> LATIN SMALL LETTER G WITH BREVE
263             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
264             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
265             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
266             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
267             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
268             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
269             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
270             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
271             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
272             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
273             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
274              
275             # CaseFolding-6.1.0.txt
276             # Date: 2011-07-25, 21:21:56 GMT [MD]
277             #
278             # T: special case for uppercase I and dotted uppercase I
279             # - For non-Turkic languages, this mapping is normally not used.
280             # - For Turkic languages (tr, az), this mapping can be used instead of the normal mapping for these characters.
281             # Note that the Turkic mappings do not maintain canonical equivalence without additional processing.
282             # See the discussions of case mapping in the Unicode Standard for more information.
283              
284             #-------------------------------------------------------------------------------
285             "\xDD" => "\x69", # LATIN CAPITAL LETTER I WITH DOT ABOVE
286             # --> LATIN SMALL LETTER I (without COMBINING DOT ABOVE)
287             #-------------------------------------------------------------------------------
288              
289             "\xDE" => "\xFE", # LATIN CAPITAL LETTER S WITH CEDILLA --> LATIN SMALL LETTER S WITH CEDILLA
290             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
291             );
292             }
293              
294             else {
295             croak "Don't know my package name '@{[__PACKAGE__]}'";
296             }
297              
298             #
299             # @ARGV wildcard globbing
300             #
301             sub import {
302              
303 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
304 0         0 my @argv = ();
305 0         0 for (@ARGV) {
306              
307             # has space
308 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
309 0 0       0 if (my @glob = Elatin5::glob(qq{"$_"})) {
310 0         0 push @argv, @glob;
311             }
312             else {
313 0         0 push @argv, $_;
314             }
315             }
316              
317             # has wildcard metachar
318             elsif (/\A (?:$q_char)*? [*?] /oxms) {
319 0 0       0 if (my @glob = Elatin5::glob($_)) {
320 0         0 push @argv, @glob;
321             }
322             else {
323 0         0 push @argv, $_;
324             }
325             }
326              
327             # no wildcard globbing
328             else {
329 0         0 push @argv, $_;
330             }
331             }
332 0         0 @ARGV = @argv;
333             }
334              
335 0         0 *Char::ord = \&Latin5::ord;
336 0         0 *Char::ord_ = \&Latin5::ord_;
337 0         0 *Char::reverse = \&Latin5::reverse;
338 0         0 *Char::getc = \&Latin5::getc;
339 0         0 *Char::length = \&Latin5::length;
340 0         0 *Char::substr = \&Latin5::substr;
341 0         0 *Char::index = \&Latin5::index;
342 0         0 *Char::rindex = \&Latin5::rindex;
343 0         0 *Char::eval = \&Latin5::eval;
344 0         0 *Char::escape = \&Latin5::escape;
345 0         0 *Char::escape_token = \&Latin5::escape_token;
346 0         0 *Char::escape_script = \&Latin5::escape_script;
347             }
348              
349             # P.230 Care with Prototypes
350             # in Chapter 6: Subroutines
351             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
352             #
353             # If you aren't careful, you can get yourself into trouble with prototypes.
354             # But if you are careful, you can do a lot of neat things with them. This is
355             # all very powerful, of course, and should only be used in moderation to make
356             # the world a better place.
357              
358             # P.332 Care with Prototypes
359             # in Chapter 7: Subroutines
360             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
361             #
362             # If you aren't careful, you can get yourself into trouble with prototypes.
363             # But if you are careful, you can do a lot of neat things with them. This is
364             # all very powerful, of course, and should only be used in moderation to make
365             # the world a better place.
366              
367             #
368             # Prototypes of subroutines
369             #
370       0     sub unimport {}
371             sub Elatin5::split(;$$$);
372             sub Elatin5::tr($$$$;$);
373             sub Elatin5::chop(@);
374             sub Elatin5::index($$;$);
375             sub Elatin5::rindex($$;$);
376             sub Elatin5::lcfirst(@);
377             sub Elatin5::lcfirst_();
378             sub Elatin5::lc(@);
379             sub Elatin5::lc_();
380             sub Elatin5::ucfirst(@);
381             sub Elatin5::ucfirst_();
382             sub Elatin5::uc(@);
383             sub Elatin5::uc_();
384             sub Elatin5::fc(@);
385             sub Elatin5::fc_();
386             sub Elatin5::ignorecase;
387             sub Elatin5::classic_character_class;
388             sub Elatin5::capture;
389             sub Elatin5::chr(;$);
390             sub Elatin5::chr_();
391             sub Elatin5::glob($);
392             sub Elatin5::glob_();
393              
394             sub Latin5::ord(;$);
395             sub Latin5::ord_();
396             sub Latin5::reverse(@);
397             sub Latin5::getc(;*@);
398             sub Latin5::length(;$);
399             sub Latin5::substr($$;$$);
400             sub Latin5::index($$;$);
401             sub Latin5::rindex($$;$);
402             sub Latin5::escape(;$);
403              
404             #
405             # Regexp work
406             #
407 200     200   14390 BEGIN { CORE::eval q{ use vars qw(
  200     200   1113  
  200         330  
  200         73227  
408             $Latin5::re_a
409             $Latin5::re_t
410             $Latin5::re_n
411             $Latin5::re_r
412             ) } }
413              
414             #
415             # Character class
416             #
417 200     200   15333 BEGIN { CORE::eval q{ use vars qw(
  200     200   1033  
  200         281  
  200         2462268  
418             $dot
419             $dot_s
420             $eD
421             $eS
422             $eW
423             $eH
424             $eV
425             $eR
426             $eN
427             $not_alnum
428             $not_alpha
429             $not_ascii
430             $not_blank
431             $not_cntrl
432             $not_digit
433             $not_graph
434             $not_lower
435             $not_lower_i
436             $not_print
437             $not_punct
438             $not_space
439             $not_upper
440             $not_upper_i
441             $not_word
442             $not_xdigit
443             $eb
444             $eB
445             ) } }
446              
447             ${Elatin5::dot} = qr{(?>[^\x0A])};
448             ${Elatin5::dot_s} = qr{(?>[\x00-\xFF])};
449             ${Elatin5::eD} = qr{(?>[^0-9])};
450              
451             # Vertical tabs are now whitespace
452             # \s in a regex now matches a vertical tab in all circumstances.
453             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
454             # ${Elatin5::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
455             # ${Elatin5::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
456             ${Elatin5::eS} = qr{(?>[^\s])};
457              
458             ${Elatin5::eW} = qr{(?>[^0-9A-Z_a-z])};
459             ${Elatin5::eH} = qr{(?>[^\x09\x20])};
460             ${Elatin5::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
461             ${Elatin5::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
462             ${Elatin5::eN} = qr{(?>[^\x0A])};
463             ${Elatin5::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
464             ${Elatin5::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
465             ${Elatin5::not_ascii} = qr{(?>[^\x00-\x7F])};
466             ${Elatin5::not_blank} = qr{(?>[^\x09\x20])};
467             ${Elatin5::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
468             ${Elatin5::not_digit} = qr{(?>[^\x30-\x39])};
469             ${Elatin5::not_graph} = qr{(?>[^\x21-\x7F])};
470             ${Elatin5::not_lower} = qr{(?>[^\x61-\x7A])};
471             ${Elatin5::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
472             # ${Elatin5::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
473             ${Elatin5::not_print} = qr{(?>[^\x20-\x7F])};
474             ${Elatin5::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
475             ${Elatin5::not_space} = qr{(?>[^\s\x0B])};
476             ${Elatin5::not_upper} = qr{(?>[^\x41-\x5A])};
477             ${Elatin5::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
478             # ${Elatin5::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
479             ${Elatin5::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
480             ${Elatin5::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
481             ${Elatin5::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
482             ${Elatin5::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
483              
484             # avoid: Name "Elatin5::foo" used only once: possible typo at here.
485             ${Elatin5::dot} = ${Elatin5::dot};
486             ${Elatin5::dot_s} = ${Elatin5::dot_s};
487             ${Elatin5::eD} = ${Elatin5::eD};
488             ${Elatin5::eS} = ${Elatin5::eS};
489             ${Elatin5::eW} = ${Elatin5::eW};
490             ${Elatin5::eH} = ${Elatin5::eH};
491             ${Elatin5::eV} = ${Elatin5::eV};
492             ${Elatin5::eR} = ${Elatin5::eR};
493             ${Elatin5::eN} = ${Elatin5::eN};
494             ${Elatin5::not_alnum} = ${Elatin5::not_alnum};
495             ${Elatin5::not_alpha} = ${Elatin5::not_alpha};
496             ${Elatin5::not_ascii} = ${Elatin5::not_ascii};
497             ${Elatin5::not_blank} = ${Elatin5::not_blank};
498             ${Elatin5::not_cntrl} = ${Elatin5::not_cntrl};
499             ${Elatin5::not_digit} = ${Elatin5::not_digit};
500             ${Elatin5::not_graph} = ${Elatin5::not_graph};
501             ${Elatin5::not_lower} = ${Elatin5::not_lower};
502             ${Elatin5::not_lower_i} = ${Elatin5::not_lower_i};
503             ${Elatin5::not_print} = ${Elatin5::not_print};
504             ${Elatin5::not_punct} = ${Elatin5::not_punct};
505             ${Elatin5::not_space} = ${Elatin5::not_space};
506             ${Elatin5::not_upper} = ${Elatin5::not_upper};
507             ${Elatin5::not_upper_i} = ${Elatin5::not_upper_i};
508             ${Elatin5::not_word} = ${Elatin5::not_word};
509             ${Elatin5::not_xdigit} = ${Elatin5::not_xdigit};
510             ${Elatin5::eb} = ${Elatin5::eb};
511             ${Elatin5::eB} = ${Elatin5::eB};
512              
513             #
514             # Latin-5 split
515             #
516             sub Elatin5::split(;$$$) {
517              
518             # P.794 29.2.161. split
519             # in Chapter 29: Functions
520             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
521              
522             # P.951 split
523             # in Chapter 27: Functions
524             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
525              
526 0     0 0 0 my $pattern = $_[0];
527 0         0 my $string = $_[1];
528 0         0 my $limit = $_[2];
529              
530             # if $pattern is also omitted or is the literal space, " "
531 0 0       0 if (not defined $pattern) {
532 0         0 $pattern = ' ';
533             }
534              
535             # if $string is omitted, the function splits the $_ string
536 0 0       0 if (not defined $string) {
537 0 0       0 if (defined $_) {
538 0         0 $string = $_;
539             }
540             else {
541 0         0 $string = '';
542             }
543             }
544              
545 0         0 my @split = ();
546              
547             # when string is empty
548 0 0       0 if ($string eq '') {
    0          
549              
550             # resulting list value in list context
551 0 0       0 if (wantarray) {
552 0         0 return @split;
553             }
554              
555             # count of substrings in scalar context
556             else {
557 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
558 0         0 @_ = @split;
559 0         0 return scalar @_;
560             }
561             }
562              
563             # split's first argument is more consistently interpreted
564             #
565             # After some changes earlier in v5.17, split's behavior has been simplified:
566             # if the PATTERN argument evaluates to a string containing one space, it is
567             # treated the way that a literal string containing one space once was.
568             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
569              
570             # if $pattern is also omitted or is the literal space, " ", the function splits
571             # on whitespace, /\s+/, after skipping any leading whitespace
572             # (and so on)
573              
574             elsif ($pattern eq ' ') {
575 0 0       0 if (not defined $limit) {
576 0         0 return CORE::split(' ', $string);
577             }
578             else {
579 0         0 return CORE::split(' ', $string, $limit);
580             }
581             }
582              
583             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
584 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
585              
586             # a pattern capable of matching either the null string or something longer than the
587             # null string will split the value of $string into separate characters wherever it
588             # matches the null string between characters
589             # (and so on)
590              
591 0 0       0 if ('' =~ / \A $pattern \z /xms) {
592 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
593 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
594              
595             # P.1024 Appendix W.10 Multibyte Processing
596             # of ISBN 1-56592-224-7 CJKV Information Processing
597             # (and so on)
598              
599             # the //m modifier is assumed when you split on the pattern /^/
600             # (and so on)
601              
602             # V
603 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
604              
605             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
606             # is included in the resulting list, interspersed with the fields that are ordinarily returned
607             # (and so on)
608              
609 0         0 local $@;
610 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
611 0         0 push @split, CORE::eval('$' . $digit);
612             }
613             }
614             }
615              
616             else {
617 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
618              
619             # V
620 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
621 0         0 local $@;
622 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
623 0         0 push @split, CORE::eval('$' . $digit);
624             }
625             }
626             }
627             }
628              
629             elsif ($limit > 0) {
630 0 0       0 if ('' =~ / \A $pattern \z /xms) {
631 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
632 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
633              
634             # V
635 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
636 0         0 local $@;
637 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
638 0         0 push @split, CORE::eval('$' . $digit);
639             }
640             }
641             }
642             }
643             else {
644 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
645 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
646              
647             # V
648 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
649 0         0 local $@;
650 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
651 0         0 push @split, CORE::eval('$' . $digit);
652             }
653             }
654             }
655             }
656             }
657              
658 0 0       0 if (CORE::length($string) > 0) {
659 0         0 push @split, $string;
660             }
661              
662             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
663 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
664 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
665 0         0 pop @split;
666             }
667             }
668              
669             # resulting list value in list context
670 0 0       0 if (wantarray) {
671 0         0 return @split;
672             }
673              
674             # count of substrings in scalar context
675             else {
676 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
677 0         0 @_ = @split;
678 0         0 return scalar @_;
679             }
680             }
681              
682             #
683             # get last subexpression offsets
684             #
685             sub _last_subexpression_offsets {
686 0     0   0 my $pattern = $_[0];
687              
688             # remove comment
689 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
690              
691 0         0 my $modifier = '';
692 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
693 0         0 $modifier = $1;
694 0         0 $modifier =~ s/-[A-Za-z]*//;
695             }
696              
697             # with /x modifier
698 0         0 my @char = ();
699 0 0       0 if ($modifier =~ /x/oxms) {
700 0         0 @char = $pattern =~ /\G((?>
701             [^\\\#\[\(] |
702             \\ $q_char |
703             \# (?>[^\n]*) $ |
704             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
705             \(\? |
706             $q_char
707             ))/oxmsg;
708             }
709              
710             # without /x modifier
711             else {
712 0         0 @char = $pattern =~ /\G((?>
713             [^\\\[\(] |
714             \\ $q_char |
715             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
716             \(\? |
717             $q_char
718             ))/oxmsg;
719             }
720              
721 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
722             }
723              
724             #
725             # Latin-5 transliteration (tr///)
726             #
727             sub Elatin5::tr($$$$;$) {
728              
729 0     0 0 0 my $bind_operator = $_[1];
730 0         0 my $searchlist = $_[2];
731 0         0 my $replacementlist = $_[3];
732 0   0     0 my $modifier = $_[4] || '';
733              
734 0 0       0 if ($modifier =~ /r/oxms) {
735 0 0       0 if ($bind_operator =~ / !~ /oxms) {
736 0         0 croak "Using !~ with tr///r doesn't make sense";
737             }
738             }
739              
740 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
741 0         0 my @searchlist = _charlist_tr($searchlist);
742 0         0 my @replacementlist = _charlist_tr($replacementlist);
743              
744 0         0 my %tr = ();
745 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
746 0 0       0 if (not exists $tr{$searchlist[$i]}) {
747 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
748 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
749             }
750             elsif ($modifier =~ /d/oxms) {
751 0         0 $tr{$searchlist[$i]} = '';
752             }
753             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
754 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
755             }
756             else {
757 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
758             }
759             }
760             }
761              
762 0         0 my $tr = 0;
763 0         0 my $replaced = '';
764 0 0       0 if ($modifier =~ /c/oxms) {
765 0         0 while (defined(my $char = shift @char)) {
766 0 0       0 if (not exists $tr{$char}) {
767 0 0       0 if (defined $replacementlist[0]) {
768 0         0 $replaced .= $replacementlist[0];
769             }
770 0         0 $tr++;
771 0 0       0 if ($modifier =~ /s/oxms) {
772 0   0     0 while (@char and (not exists $tr{$char[0]})) {
773 0         0 shift @char;
774 0         0 $tr++;
775             }
776             }
777             }
778             else {
779 0         0 $replaced .= $char;
780             }
781             }
782             }
783             else {
784 0         0 while (defined(my $char = shift @char)) {
785 0 0       0 if (exists $tr{$char}) {
786 0         0 $replaced .= $tr{$char};
787 0         0 $tr++;
788 0 0       0 if ($modifier =~ /s/oxms) {
789 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
790 0         0 shift @char;
791 0         0 $tr++;
792             }
793             }
794             }
795             else {
796 0         0 $replaced .= $char;
797             }
798             }
799             }
800              
801 0 0       0 if ($modifier =~ /r/oxms) {
802 0         0 return $replaced;
803             }
804             else {
805 0         0 $_[0] = $replaced;
806 0 0       0 if ($bind_operator =~ / !~ /oxms) {
807 0         0 return not $tr;
808             }
809             else {
810 0         0 return $tr;
811             }
812             }
813             }
814              
815             #
816             # Latin-5 chop
817             #
818             sub Elatin5::chop(@) {
819              
820 0     0 0 0 my $chop;
821 0 0       0 if (@_ == 0) {
822 0         0 my @char = /\G (?>$q_char) /oxmsg;
823 0         0 $chop = pop @char;
824 0         0 $_ = join '', @char;
825             }
826             else {
827 0         0 for (@_) {
828 0         0 my @char = /\G (?>$q_char) /oxmsg;
829 0         0 $chop = pop @char;
830 0         0 $_ = join '', @char;
831             }
832             }
833 0         0 return $chop;
834             }
835              
836             #
837             # Latin-5 index by octet
838             #
839             sub Elatin5::index($$;$) {
840              
841 0     0 1 0 my($str,$substr,$position) = @_;
842 0   0     0 $position ||= 0;
843 0         0 my $pos = 0;
844              
845 0         0 while ($pos < CORE::length($str)) {
846 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
847 0 0       0 if ($pos >= $position) {
848 0         0 return $pos;
849             }
850             }
851 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
852 0         0 $pos += CORE::length($1);
853             }
854             else {
855 0         0 $pos += 1;
856             }
857             }
858 0         0 return -1;
859             }
860              
861             #
862             # Latin-5 reverse index
863             #
864             sub Elatin5::rindex($$;$) {
865              
866 0     0 0 0 my($str,$substr,$position) = @_;
867 0   0     0 $position ||= CORE::length($str) - 1;
868 0         0 my $pos = 0;
869 0         0 my $rindex = -1;
870              
871 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
872 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
873 0         0 $rindex = $pos;
874             }
875 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
876 0         0 $pos += CORE::length($1);
877             }
878             else {
879 0         0 $pos += 1;
880             }
881             }
882 0         0 return $rindex;
883             }
884              
885             #
886             # Latin-5 lower case first with parameter
887             #
888             sub Elatin5::lcfirst(@) {
889 0 0   0 0 0 if (@_) {
890 0         0 my $s = shift @_;
891 0 0 0     0 if (@_ and wantarray) {
892 0         0 return Elatin5::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
893             }
894             else {
895 0         0 return Elatin5::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
896             }
897             }
898             else {
899 0         0 return Elatin5::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
900             }
901             }
902              
903             #
904             # Latin-5 lower case first without parameter
905             #
906             sub Elatin5::lcfirst_() {
907 0     0 0 0 return Elatin5::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
908             }
909              
910             #
911             # Latin-5 lower case with parameter
912             #
913             sub Elatin5::lc(@) {
914 0 0   0 0 0 if (@_) {
915 0         0 my $s = shift @_;
916 0 0 0     0 if (@_ and wantarray) {
917 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
918             }
919             else {
920 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
921             }
922             }
923             else {
924 0         0 return Elatin5::lc_();
925             }
926             }
927              
928             #
929             # Latin-5 lower case without parameter
930             #
931             sub Elatin5::lc_() {
932 0     0 0 0 my $s = $_;
933 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
934             }
935              
936             #
937             # Latin-5 upper case first with parameter
938             #
939             sub Elatin5::ucfirst(@) {
940 0 0   0 0 0 if (@_) {
941 0         0 my $s = shift @_;
942 0 0 0     0 if (@_ and wantarray) {
943 0         0 return Elatin5::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
944             }
945             else {
946 0         0 return Elatin5::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
947             }
948             }
949             else {
950 0         0 return Elatin5::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
951             }
952             }
953              
954             #
955             # Latin-5 upper case first without parameter
956             #
957             sub Elatin5::ucfirst_() {
958 0     0 0 0 return Elatin5::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
959             }
960              
961             #
962             # Latin-5 upper case with parameter
963             #
964             sub Elatin5::uc(@) {
965 174 50   174 0 274 if (@_) {
966 174         206 my $s = shift @_;
967 174 50 33     421 if (@_ and wantarray) {
968 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
969             }
970             else {
971 174 100       657 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         732  
972             }
973             }
974             else {
975 0         0 return Elatin5::uc_();
976             }
977             }
978              
979             #
980             # Latin-5 upper case without parameter
981             #
982             sub Elatin5::uc_() {
983 0     0 0 0 my $s = $_;
984 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
985             }
986              
987             #
988             # Latin-5 fold case with parameter
989             #
990             sub Elatin5::fc(@) {
991 197 50   197 0 289 if (@_) {
992 197         225 my $s = shift @_;
993 197 50 33     432 if (@_ and wantarray) {
994 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
995             }
996             else {
997 197 100       563 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         1251  
998             }
999             }
1000             else {
1001 0         0 return Elatin5::fc_();
1002             }
1003             }
1004              
1005             #
1006             # Latin-5 fold case without parameter
1007             #
1008             sub Elatin5::fc_() {
1009 0     0 0 0 my $s = $_;
1010 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1011             }
1012              
1013             #
1014             # Latin-5 regexp capture
1015             #
1016             {
1017             sub Elatin5::capture {
1018 0     0 1 0 return $_[0];
1019             }
1020             }
1021              
1022             #
1023             # Latin-5 regexp ignore case modifier
1024             #
1025             sub Elatin5::ignorecase {
1026              
1027 0     0 0 0 my @string = @_;
1028 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1029              
1030             # ignore case of $scalar or @array
1031 0         0 for my $string (@string) {
1032              
1033             # split regexp
1034 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1035              
1036             # unescape character
1037 0         0 for (my $i=0; $i <= $#char; $i++) {
1038 0 0       0 next if not defined $char[$i];
1039              
1040             # open character class [...]
1041 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1042 0         0 my $left = $i;
1043              
1044             # [] make die "unmatched [] in regexp ...\n"
1045              
1046 0 0       0 if ($char[$i+1] eq ']') {
1047 0         0 $i++;
1048             }
1049              
1050 0         0 while (1) {
1051 0 0       0 if (++$i > $#char) {
1052 0         0 croak "Unmatched [] in regexp";
1053             }
1054 0 0       0 if ($char[$i] eq ']') {
1055 0         0 my $right = $i;
1056 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1057              
1058             # escape character
1059 0         0 for my $char (@charlist) {
1060 0 0       0 if (0) {
1061             }
1062              
1063 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1064 0         0 $char = '\\' . $char;
1065             }
1066             }
1067              
1068             # [...]
1069 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1070              
1071 0         0 $i = $left;
1072 0         0 last;
1073             }
1074             }
1075             }
1076              
1077             # open character class [^...]
1078             elsif ($char[$i] eq '[^') {
1079 0         0 my $left = $i;
1080              
1081             # [^] make die "unmatched [] in regexp ...\n"
1082              
1083 0 0       0 if ($char[$i+1] eq ']') {
1084 0         0 $i++;
1085             }
1086              
1087 0         0 while (1) {
1088 0 0       0 if (++$i > $#char) {
1089 0         0 croak "Unmatched [] in regexp";
1090             }
1091 0 0       0 if ($char[$i] eq ']') {
1092 0         0 my $right = $i;
1093 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1094              
1095             # escape character
1096 0         0 for my $char (@charlist) {
1097 0 0       0 if (0) {
1098             }
1099              
1100 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1101 0         0 $char = '\\' . $char;
1102             }
1103             }
1104              
1105             # [^...]
1106 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1107              
1108 0         0 $i = $left;
1109 0         0 last;
1110             }
1111             }
1112             }
1113              
1114             # rewrite classic character class or escape character
1115             elsif (my $char = classic_character_class($char[$i])) {
1116 0         0 $char[$i] = $char;
1117             }
1118              
1119             # with /i modifier
1120             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1121 0         0 my $uc = Elatin5::uc($char[$i]);
1122 0         0 my $fc = Elatin5::fc($char[$i]);
1123 0 0       0 if ($uc ne $fc) {
1124 0 0       0 if (CORE::length($fc) == 1) {
1125 0         0 $char[$i] = '[' . $uc . $fc . ']';
1126             }
1127             else {
1128 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1129             }
1130             }
1131             }
1132             }
1133              
1134             # characterize
1135 0         0 for (my $i=0; $i <= $#char; $i++) {
1136 0 0       0 next if not defined $char[$i];
1137              
1138 0 0       0 if (0) {
1139             }
1140              
1141             # quote character before ? + * {
1142 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1143 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1144 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1145             }
1146             }
1147             }
1148              
1149 0         0 $string = join '', @char;
1150             }
1151              
1152             # make regexp string
1153 0         0 return @string;
1154             }
1155              
1156             #
1157             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1158             #
1159             sub Elatin5::classic_character_class {
1160 1862     1862 0 1807 my($char) = @_;
1161              
1162             return {
1163             '\D' => '${Elatin5::eD}',
1164             '\S' => '${Elatin5::eS}',
1165             '\W' => '${Elatin5::eW}',
1166             '\d' => '[0-9]',
1167              
1168             # Before Perl 5.6, \s only matched the five whitespace characters
1169             # tab, newline, form-feed, carriage return, and the space character
1170             # itself, which, taken together, is the character class [\t\n\f\r ].
1171              
1172             # Vertical tabs are now whitespace
1173             # \s in a regex now matches a vertical tab in all circumstances.
1174             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1175             # \t \n \v \f \r space
1176             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1177             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1178             '\s' => '\s',
1179              
1180             '\w' => '[0-9A-Z_a-z]',
1181             '\C' => '[\x00-\xFF]',
1182             '\X' => 'X',
1183              
1184             # \h \v \H \V
1185              
1186             # P.114 Character Class Shortcuts
1187             # in Chapter 7: In the World of Regular Expressions
1188             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1189              
1190             # P.357 13.2.3 Whitespace
1191             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1192             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1193             #
1194             # 0x00009 CHARACTER TABULATION h s
1195             # 0x0000a LINE FEED (LF) vs
1196             # 0x0000b LINE TABULATION v
1197             # 0x0000c FORM FEED (FF) vs
1198             # 0x0000d CARRIAGE RETURN (CR) vs
1199             # 0x00020 SPACE h s
1200              
1201             # P.196 Table 5-9. Alphanumeric regex metasymbols
1202             # in Chapter 5. Pattern Matching
1203             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1204              
1205             # (and so on)
1206              
1207             '\H' => '${Elatin5::eH}',
1208             '\V' => '${Elatin5::eV}',
1209             '\h' => '[\x09\x20]',
1210             '\v' => '[\x0A\x0B\x0C\x0D]',
1211             '\R' => '${Elatin5::eR}',
1212              
1213             # \N
1214             #
1215             # http://perldoc.perl.org/perlre.html
1216             # Character Classes and other Special Escapes
1217             # Any character but \n (experimental). Not affected by /s modifier
1218              
1219             '\N' => '${Elatin5::eN}',
1220              
1221             # \b \B
1222              
1223             # P.180 Boundaries: The \b and \B Assertions
1224             # in Chapter 5: Pattern Matching
1225             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1226              
1227             # P.219 Boundaries: The \b and \B Assertions
1228             # in Chapter 5: Pattern Matching
1229             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1230              
1231             # \b really means (?:(?<=\w)(?!\w)|(?
1232             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1233             '\b' => '${Elatin5::eb}',
1234              
1235             # \B really means (?:(?<=\w)(?=\w)|(?
1236             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1237             '\B' => '${Elatin5::eB}',
1238              
1239 1862   100     81940 }->{$char} || '';
1240             }
1241              
1242             #
1243             # prepare Latin-5 characters per length
1244             #
1245              
1246             # 1 octet characters
1247             my @chars1 = ();
1248             sub chars1 {
1249 0 0   0 0 0 if (@chars1) {
1250 0         0 return @chars1;
1251             }
1252 0 0       0 if (exists $range_tr{1}) {
1253 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1254 0         0 while (my @range = splice(@ranges,0,1)) {
1255 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1256 0         0 push @chars1, pack 'C', $oct0;
1257             }
1258             }
1259             }
1260 0         0 return @chars1;
1261             }
1262              
1263             # 2 octets characters
1264             my @chars2 = ();
1265             sub chars2 {
1266 0 0   0 0 0 if (@chars2) {
1267 0         0 return @chars2;
1268             }
1269 0 0       0 if (exists $range_tr{2}) {
1270 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1271 0         0 while (my @range = splice(@ranges,0,2)) {
1272 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1273 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1274 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1275             }
1276             }
1277             }
1278             }
1279 0         0 return @chars2;
1280             }
1281              
1282             # 3 octets characters
1283             my @chars3 = ();
1284             sub chars3 {
1285 0 0   0 0 0 if (@chars3) {
1286 0         0 return @chars3;
1287             }
1288 0 0       0 if (exists $range_tr{3}) {
1289 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1290 0         0 while (my @range = splice(@ranges,0,3)) {
1291 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1292 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1293 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1294 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1295             }
1296             }
1297             }
1298             }
1299             }
1300 0         0 return @chars3;
1301             }
1302              
1303             # 4 octets characters
1304             my @chars4 = ();
1305             sub chars4 {
1306 0 0   0 0 0 if (@chars4) {
1307 0         0 return @chars4;
1308             }
1309 0 0       0 if (exists $range_tr{4}) {
1310 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1311 0         0 while (my @range = splice(@ranges,0,4)) {
1312 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1313 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1314 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1315 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1316 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1317             }
1318             }
1319             }
1320             }
1321             }
1322             }
1323 0         0 return @chars4;
1324             }
1325              
1326             #
1327             # Latin-5 open character list for tr
1328             #
1329             sub _charlist_tr {
1330              
1331 0     0   0 local $_ = shift @_;
1332              
1333             # unescape character
1334 0         0 my @char = ();
1335 0         0 while (not /\G \z/oxmsgc) {
1336 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1337 0         0 push @char, '\-';
1338             }
1339             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(oct $1);
1341             }
1342             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1343 0         0 push @char, CORE::chr(hex $1);
1344             }
1345             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1346 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1347             }
1348             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1349             push @char, {
1350             '\0' => "\0",
1351             '\n' => "\n",
1352             '\r' => "\r",
1353             '\t' => "\t",
1354             '\f' => "\f",
1355             '\b' => "\x08", # \b means backspace in character class
1356             '\a' => "\a",
1357             '\e' => "\e",
1358 0         0 }->{$1};
1359             }
1360             elsif (/\G \\ ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             elsif (/\G ($q_char) /oxmsgc) {
1364 0         0 push @char, $1;
1365             }
1366             }
1367              
1368             # join separated multiple-octet
1369 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1370              
1371             # unescape '-'
1372 0         0 my @i = ();
1373 0         0 for my $i (0 .. $#char) {
1374 0 0       0 if ($char[$i] eq '\-') {
    0          
1375 0         0 $char[$i] = '-';
1376             }
1377             elsif ($char[$i] eq '-') {
1378 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1379 0         0 push @i, $i;
1380             }
1381             }
1382             }
1383              
1384             # open character list (reverse for splice)
1385 0         0 for my $i (CORE::reverse @i) {
1386 0         0 my @range = ();
1387              
1388             # range error
1389 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1390 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1391             }
1392              
1393             # range of multiple-octet code
1394 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1395 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1396 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1397             }
1398             elsif (CORE::length($char[$i+1]) == 2) {
1399 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1400 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1401             }
1402             elsif (CORE::length($char[$i+1]) == 3) {
1403 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1404 0         0 push @range, chars2();
1405 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1406             }
1407             elsif (CORE::length($char[$i+1]) == 4) {
1408 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1409 0         0 push @range, chars2();
1410 0         0 push @range, chars3();
1411 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1412             }
1413             else {
1414 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1415             }
1416             }
1417             elsif (CORE::length($char[$i-1]) == 2) {
1418 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1419 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1420             }
1421             elsif (CORE::length($char[$i+1]) == 3) {
1422 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
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 $_} chars2();
  0         0  
1427 0         0 push @range, chars3();
1428 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1429             }
1430             else {
1431 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1432             }
1433             }
1434             elsif (CORE::length($char[$i-1]) == 3) {
1435 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1436 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1437             }
1438             elsif (CORE::length($char[$i+1]) == 4) {
1439 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1440 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1441             }
1442             else {
1443 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1444             }
1445             }
1446             elsif (CORE::length($char[$i-1]) == 4) {
1447 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1448 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1449             }
1450             else {
1451 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1452             }
1453             }
1454             else {
1455 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1456             }
1457              
1458 0         0 splice @char, $i-1, 3, @range;
1459             }
1460              
1461 0         0 return @char;
1462             }
1463              
1464             #
1465             # Latin-5 open character class
1466             #
1467             sub _cc {
1468 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1469 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1470             }
1471             elsif (scalar(@_) == 1) {
1472 0         0 return sprintf('\x%02X',$_[0]);
1473             }
1474             elsif (scalar(@_) == 2) {
1475 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1476 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1477             }
1478             elsif ($_[0] == $_[1]) {
1479 0         0 return sprintf('\x%02X',$_[0]);
1480             }
1481             elsif (($_[0]+1) == $_[1]) {
1482 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1483             }
1484             else {
1485 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1486             }
1487             }
1488             else {
1489 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1490             }
1491             }
1492              
1493             #
1494             # Latin-5 octet range
1495             #
1496             sub _octets {
1497 182     182   320 my $length = shift @_;
1498              
1499 182 50       385 if ($length == 1) {
1500 182         599 my($a1) = unpack 'C', $_[0];
1501 182         342 my($z1) = unpack 'C', $_[1];
1502              
1503 182 50       410 if ($a1 > $z1) {
1504 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1505             }
1506              
1507 182 50       562 if ($a1 == $z1) {
    50          
1508 0         0 return sprintf('\x%02X',$a1);
1509             }
1510             elsif (($a1+1) == $z1) {
1511 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1512             }
1513             else {
1514 182         1462 return sprintf('\x%02X-\x%02X',$a1,$z1);
1515             }
1516             }
1517             else {
1518 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1519             }
1520             }
1521              
1522             #
1523             # Latin-5 range regexp
1524             #
1525             sub _range_regexp {
1526 182     182   328 my($length,$first,$last) = @_;
1527              
1528 182         271 my @range_regexp = ();
1529 182 50       587 if (not exists $range_tr{$length}) {
1530 0         0 return @range_regexp;
1531             }
1532              
1533 182         210 my @ranges = @{ $range_tr{$length} };
  182         493  
1534 182         721 while (my @range = splice(@ranges,0,$length)) {
1535 182         255 my $min = '';
1536 182         193 my $max = '';
1537 182         529 for (my $i=0; $i < $length; $i++) {
1538 182         889 $min .= pack 'C', $range[$i][0];
1539 182         589 $max .= pack 'C', $range[$i][-1];
1540             }
1541              
1542             # min___max
1543             # FIRST_____________LAST
1544             # (nothing)
1545              
1546 182 50 33     2680 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1547             }
1548              
1549             # **********
1550             # min_________max
1551             # FIRST_____________LAST
1552             # **********
1553              
1554             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1555 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1556             }
1557              
1558             # **********************
1559             # min________________max
1560             # FIRST_____________LAST
1561             # **********************
1562              
1563             elsif (($min eq $first) and ($max eq $last)) {
1564 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1565             }
1566              
1567             # *********
1568             # min___max
1569             # FIRST_____________LAST
1570             # *********
1571              
1572             elsif (($first le $min) and ($max le $last)) {
1573 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1574             }
1575              
1576             # **********************
1577             # min__________________________max
1578             # FIRST_____________LAST
1579             # **********************
1580              
1581             elsif (($min le $first) and ($last le $max)) {
1582 182         501 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 ($min le $last) and ($last le $max)) {
1591 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1592             }
1593              
1594             # min___max
1595             # FIRST_____________LAST
1596             # (nothing)
1597              
1598             elsif ($last lt $min) {
1599             }
1600              
1601             else {
1602 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1603             }
1604             }
1605              
1606 182         418 return @range_regexp;
1607             }
1608              
1609             #
1610             # Latin-5 open character list for qr and not qr
1611             #
1612             sub _charlist {
1613              
1614 358     358   559 my $modifier = pop @_;
1615 358         728 my @char = @_;
1616              
1617 358 100       909 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1618              
1619             # unescape character
1620 358         1167 for (my $i=0; $i <= $#char; $i++) {
1621              
1622             # escape - to ...
1623 1125 100 100     10616 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1624 206 100 100     1058 if ((0 < $i) and ($i < $#char)) {
1625 182         463 $char[$i] = '...';
1626             }
1627             }
1628              
1629             # octal escape sequence
1630             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1631 0         0 $char[$i] = octchr($1);
1632             }
1633              
1634             # hexadecimal escape sequence
1635             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1636 0         0 $char[$i] = hexchr($1);
1637             }
1638              
1639             # \b{...} --> b\{...}
1640             # \B{...} --> B\{...}
1641             # \N{CHARNAME} --> N\{CHARNAME}
1642             # \p{PROPERTY} --> p\{PROPERTY}
1643             # \P{PROPERTY} --> P\{PROPERTY}
1644             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1645 0         0 $char[$i] = $1 . '\\' . $2;
1646             }
1647              
1648             # \p, \P, \X --> p, P, X
1649             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1650 0         0 $char[$i] = $1;
1651             }
1652              
1653             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1654 0         0 $char[$i] = CORE::chr oct $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1657 22         130 $char[$i] = CORE::chr hex $1;
1658             }
1659             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1660 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1661             }
1662             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1663             $char[$i] = {
1664             '\0' => "\0",
1665             '\n' => "\n",
1666             '\r' => "\r",
1667             '\t' => "\t",
1668             '\f' => "\f",
1669             '\b' => "\x08", # \b means backspace in character class
1670             '\a' => "\a",
1671             '\e' => "\e",
1672             '\d' => '[0-9]',
1673              
1674             # Vertical tabs are now whitespace
1675             # \s in a regex now matches a vertical tab in all circumstances.
1676             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1677             # \t \n \v \f \r space
1678             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1679             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1680             '\s' => '\s',
1681              
1682             '\w' => '[0-9A-Z_a-z]',
1683             '\D' => '${Elatin5::eD}',
1684             '\S' => '${Elatin5::eS}',
1685             '\W' => '${Elatin5::eW}',
1686              
1687             '\H' => '${Elatin5::eH}',
1688             '\V' => '${Elatin5::eV}',
1689             '\h' => '[\x09\x20]',
1690             '\v' => '[\x0A\x0B\x0C\x0D]',
1691             '\R' => '${Elatin5::eR}',
1692              
1693 25         414 }->{$1};
1694             }
1695              
1696             # POSIX-style character classes
1697             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1698             $char[$i] = {
1699              
1700             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1701             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1702             '[:^lower:]' => '${Elatin5::not_lower_i}',
1703             '[:^upper:]' => '${Elatin5::not_upper_i}',
1704              
1705 8         74 }->{$1};
1706             }
1707             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1708             $char[$i] = {
1709              
1710             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1711             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1712             '[:ascii:]' => '[\x00-\x7F]',
1713             '[:blank:]' => '[\x09\x20]',
1714             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1715             '[:digit:]' => '[\x30-\x39]',
1716             '[:graph:]' => '[\x21-\x7F]',
1717             '[:lower:]' => '[\x61-\x7A]',
1718             '[:print:]' => '[\x20-\x7F]',
1719             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1720              
1721             # P.174 POSIX-Style Character Classes
1722             # in Chapter 5: Pattern Matching
1723             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1724              
1725             # P.311 11.2.4 Character Classes and other Special Escapes
1726             # in Chapter 11: perlre: Perl regular expressions
1727             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1728              
1729             # P.210 POSIX-Style Character Classes
1730             # in Chapter 5: Pattern Matching
1731             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1732              
1733             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1734              
1735             '[:upper:]' => '[\x41-\x5A]',
1736             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1737             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1738             '[:^alnum:]' => '${Elatin5::not_alnum}',
1739             '[:^alpha:]' => '${Elatin5::not_alpha}',
1740             '[:^ascii:]' => '${Elatin5::not_ascii}',
1741             '[:^blank:]' => '${Elatin5::not_blank}',
1742             '[:^cntrl:]' => '${Elatin5::not_cntrl}',
1743             '[:^digit:]' => '${Elatin5::not_digit}',
1744             '[:^graph:]' => '${Elatin5::not_graph}',
1745             '[:^lower:]' => '${Elatin5::not_lower}',
1746             '[:^print:]' => '${Elatin5::not_print}',
1747             '[:^punct:]' => '${Elatin5::not_punct}',
1748             '[:^space:]' => '${Elatin5::not_space}',
1749             '[:^upper:]' => '${Elatin5::not_upper}',
1750             '[:^word:]' => '${Elatin5::not_word}',
1751             '[:^xdigit:]' => '${Elatin5::not_xdigit}',
1752              
1753 70         1362 }->{$1};
1754             }
1755             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1756 7         36 $char[$i] = $1;
1757             }
1758             }
1759              
1760             # open character list
1761 358         580 my @singleoctet = ();
1762 358         465 my @multipleoctet = ();
1763 358         923 for (my $i=0; $i <= $#char; ) {
1764              
1765             # escaped -
1766 943 100 100     4880 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1767 182         223 $i += 1;
1768 182         369 next;
1769             }
1770              
1771             # make range regexp
1772             elsif ($char[$i] eq '...') {
1773              
1774             # range error
1775 182 50       891 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1776 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1777             }
1778             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1779 182 50       519 if ($char[$i-1] gt $char[$i+1]) {
1780 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]);
1781             }
1782             }
1783              
1784             # make range regexp per length
1785 182         629 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1786 182         278 my @regexp = ();
1787              
1788             # is first and last
1789 182 50 33     983 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1790 182         658 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1791             }
1792              
1793             # is first
1794             elsif ($length == CORE::length($char[$i-1])) {
1795 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1796             }
1797              
1798             # is inside in first and last
1799             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1800 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1801             }
1802              
1803             # is last
1804             elsif ($length == CORE::length($char[$i+1])) {
1805 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1806             }
1807              
1808             else {
1809 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1810             }
1811              
1812 182 50       440 if ($length == 1) {
1813 182         445 push @singleoctet, @regexp;
1814             }
1815             else {
1816 0         0 push @multipleoctet, @regexp;
1817             }
1818             }
1819              
1820 182         459 $i += 2;
1821             }
1822              
1823             # with /i modifier
1824             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1825 493 100       677 if ($modifier =~ /i/oxms) {
1826 24         62 my $uc = Elatin5::uc($char[$i]);
1827 24         65 my $fc = Elatin5::fc($char[$i]);
1828 24 100       51 if ($uc ne $fc) {
1829 12 50       29 if (CORE::length($fc) == 1) {
1830 12         29 push @singleoctet, $uc, $fc;
1831             }
1832             else {
1833 0         0 push @singleoctet, $uc;
1834 0         0 push @multipleoctet, $fc;
1835             }
1836             }
1837             else {
1838 12         30 push @singleoctet, $char[$i];
1839             }
1840             }
1841             else {
1842 469         568 push @singleoctet, $char[$i];
1843             }
1844 493         755 $i += 1;
1845             }
1846              
1847             # single character of single octet code
1848             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1849 0         0 push @singleoctet, "\t", "\x20";
1850 0         0 $i += 1;
1851             }
1852             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1853 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1854 0         0 $i += 1;
1855             }
1856             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1857 2         7 push @singleoctet, $char[$i];
1858 2         8 $i += 1;
1859             }
1860              
1861             # single character of multiple-octet code
1862             else {
1863 84         126 push @multipleoctet, $char[$i];
1864 84         150 $i += 1;
1865             }
1866             }
1867              
1868             # quote metachar
1869 358         759 for (@singleoctet) {
1870 689 50       4035 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1871 0         0 $_ = '-';
1872             }
1873             elsif (/\A \n \z/oxms) {
1874 8         19 $_ = '\n';
1875             }
1876             elsif (/\A \r \z/oxms) {
1877 8         14 $_ = '\r';
1878             }
1879             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1880 60         230 $_ = sprintf('\x%02X', CORE::ord $1);
1881             }
1882             elsif (/\A [\x00-\xFF] \z/oxms) {
1883 429         554 $_ = quotemeta $_;
1884             }
1885             }
1886              
1887             # return character list
1888 358         1326 return \@singleoctet, \@multipleoctet;
1889             }
1890              
1891             #
1892             # Latin-5 octal escape sequence
1893             #
1894             sub octchr {
1895 5     5 0 9 my($octdigit) = @_;
1896              
1897 5         6 my @binary = ();
1898 5         15 for my $octal (split(//,$octdigit)) {
1899             push @binary, {
1900             '0' => '000',
1901             '1' => '001',
1902             '2' => '010',
1903             '3' => '011',
1904             '4' => '100',
1905             '5' => '101',
1906             '6' => '110',
1907             '7' => '111',
1908 50         141 }->{$octal};
1909             }
1910 5         10 my $binary = join '', @binary;
1911              
1912             my $octchr = {
1913             # 1234567
1914             1 => pack('B*', "0000000$binary"),
1915             2 => pack('B*', "000000$binary"),
1916             3 => pack('B*', "00000$binary"),
1917             4 => pack('B*', "0000$binary"),
1918             5 => pack('B*', "000$binary"),
1919             6 => pack('B*', "00$binary"),
1920             7 => pack('B*', "0$binary"),
1921             0 => pack('B*', "$binary"),
1922              
1923 5         58 }->{CORE::length($binary) % 8};
1924              
1925 5         18 return $octchr;
1926             }
1927              
1928             #
1929             # Latin-5 hexadecimal escape sequence
1930             #
1931             sub hexchr {
1932 5     5 0 10 my($hexdigit) = @_;
1933              
1934             my $hexchr = {
1935             1 => pack('H*', "0$hexdigit"),
1936             0 => pack('H*', "$hexdigit"),
1937              
1938 5         44 }->{CORE::length($_[0]) % 2};
1939              
1940 5         15 return $hexchr;
1941             }
1942              
1943             #
1944             # Latin-5 open character list for qr
1945             #
1946             sub charlist_qr {
1947              
1948 314     314 0 601 my $modifier = pop @_;
1949 314         783 my @char = @_;
1950              
1951 314         860 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1952 314         678 my @singleoctet = @$singleoctet;
1953 314         474 my @multipleoctet = @$multipleoctet;
1954              
1955             # return character list
1956 314 100       776 if (scalar(@singleoctet) >= 1) {
1957              
1958             # with /i modifier
1959 236 100       547 if ($modifier =~ m/i/oxms) {
1960 22         44 my %singleoctet_ignorecase = ();
1961 22         45 for (@singleoctet) {
1962 46   100     291 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1963 46         189 for my $ord (hex($1) .. hex($2)) {
1964 66         110 my $char = CORE::chr($ord);
1965 66         114 my $uc = Elatin5::uc($char);
1966 66         128 my $fc = Elatin5::fc($char);
1967 66 100       123 if ($uc eq $fc) {
1968 12         128 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1969             }
1970             else {
1971 54 50       87 if (CORE::length($fc) == 1) {
1972 54         145 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1973 54         288 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1974             }
1975             else {
1976 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1977 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1978             }
1979             }
1980             }
1981             }
1982 46 50       109 if ($_ ne '') {
1983 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1984             }
1985             }
1986 22         31 my $i = 0;
1987 22         37 my @singleoctet_ignorecase = ();
1988 22         50 for my $ord (0 .. 255) {
1989 5632 100       6237 if (exists $singleoctet_ignorecase{$ord}) {
1990 96         76 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         236  
1991             }
1992             else {
1993 5536         4476 $i++;
1994             }
1995             }
1996 22         54 @singleoctet = ();
1997 22         66 for my $range (@singleoctet_ignorecase) {
1998 3648 100       6654 if (ref $range) {
1999 56 100       53 if (scalar(@{$range}) == 1) {
  56 50       126  
2000 36         34 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         294  
2001             }
2002 20         34 elsif (scalar(@{$range}) == 2) {
2003 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2004             }
2005             else {
2006 20         20 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         27  
  20         103  
2007             }
2008             }
2009             }
2010             }
2011              
2012 236         345 my $not_anchor = '';
2013              
2014 236         673 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2015             }
2016 314 100       650 if (scalar(@multipleoctet) >= 2) {
2017 6         43 return '(?:' . join('|', @multipleoctet) . ')';
2018             }
2019             else {
2020 308         1349 return $multipleoctet[0];
2021             }
2022             }
2023              
2024             #
2025             # Latin-5 open character list for not qr
2026             #
2027             sub charlist_not_qr {
2028              
2029 44     44 0 91 my $modifier = pop @_;
2030 44         117 my @char = @_;
2031              
2032 44         135 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2033 44         113 my @singleoctet = @$singleoctet;
2034 44         73 my @multipleoctet = @$multipleoctet;
2035              
2036             # with /i modifier
2037 44 100       137 if ($modifier =~ m/i/oxms) {
2038 10         22 my %singleoctet_ignorecase = ();
2039 10         27 for (@singleoctet) {
2040 10   66     76 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2041 10         56 for my $ord (hex($1) .. hex($2)) {
2042 30         59 my $char = CORE::chr($ord);
2043 30         67 my $uc = Elatin5::uc($char);
2044 30         73 my $fc = Elatin5::fc($char);
2045 30 50       56 if ($uc eq $fc) {
2046 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2047             }
2048             else {
2049 30 50       54 if (CORE::length($fc) == 1) {
2050 30         85 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2051 30         145 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2052             }
2053             else {
2054 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2055 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2056             }
2057             }
2058             }
2059             }
2060 10 50       36 if ($_ ne '') {
2061 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2062             }
2063             }
2064 10         12 my $i = 0;
2065 10         17 my @singleoctet_ignorecase = ();
2066 10         22 for my $ord (0 .. 255) {
2067 2560 100       3105 if (exists $singleoctet_ignorecase{$ord}) {
2068 60         48 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         115  
2069             }
2070             else {
2071 2500         2411 $i++;
2072             }
2073             }
2074 10         29 @singleoctet = ();
2075 10         44 for my $range (@singleoctet_ignorecase) {
2076 960 100       2089 if (ref $range) {
2077 20 50       14 if (scalar(@{$range}) == 1) {
  20 50       47  
2078 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2079             }
2080 20         38 elsif (scalar(@{$range}) == 2) {
2081 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2082             }
2083             else {
2084 20         27 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         31  
  20         124  
2085             }
2086             }
2087             }
2088             }
2089              
2090             # return character list
2091 44 50       147 if (scalar(@multipleoctet) >= 1) {
2092 0 0       0 if (scalar(@singleoctet) >= 1) {
2093              
2094             # any character other than multiple-octet and single octet character class
2095 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2096             }
2097             else {
2098              
2099             # any character other than multiple-octet character class
2100 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2101             }
2102             }
2103             else {
2104 44 50       116 if (scalar(@singleoctet) >= 1) {
2105              
2106             # any character other than single octet character class
2107 44         313 return '(?:[^' . join('', @singleoctet) . '])';
2108             }
2109             else {
2110              
2111             # any character
2112 0         0 return "(?:$your_char)";
2113             }
2114             }
2115             }
2116              
2117             #
2118             # open file in read mode
2119             #
2120             sub _open_r {
2121 400     400   1834 my(undef,$file) = @_;
2122 400         1854 $file =~ s#\A (\s) #./$1#oxms;
2123 400   33     31635 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2124             open($_[0],"< $file\0");
2125             }
2126              
2127             #
2128             # open file in write mode
2129             #
2130             sub _open_w {
2131 0     0   0 my(undef,$file) = @_;
2132 0         0 $file =~ s#\A (\s) #./$1#oxms;
2133 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2134             open($_[0],"> $file\0");
2135             }
2136              
2137             #
2138             # open file in append mode
2139             #
2140             sub _open_a {
2141 0     0   0 my(undef,$file) = @_;
2142 0         0 $file =~ s#\A (\s) #./$1#oxms;
2143 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2144             open($_[0],">> $file\0");
2145             }
2146              
2147             #
2148             # safe system
2149             #
2150             sub _systemx {
2151              
2152             # P.707 29.2.33. exec
2153             # in Chapter 29: Functions
2154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2155             #
2156             # Be aware that in older releases of Perl, exec (and system) did not flush
2157             # your output buffer, so you needed to enable command buffering by setting $|
2158             # on one or more filehandles to avoid lost output in the case of exec, or
2159             # misordererd output in the case of system. This situation was largely remedied
2160             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2161              
2162             # P.855 exec
2163             # in Chapter 27: Functions
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165             #
2166             # In very old release of Perl (before v5.6), exec (and system) did not flush
2167             # your output buffer, so you needed to enable command buffering by setting $|
2168             # on one or more filehandles to avoid lost output with exec or misordered
2169             # output with system.
2170              
2171 200     200   812 $| = 1;
2172              
2173             # P.565 23.1.2. Cleaning Up Your Environment
2174             # in Chapter 23: Security
2175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2176              
2177             # P.656 Cleaning Up Your Environment
2178             # in Chapter 20: Security
2179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2180              
2181             # local $ENV{'PATH'} = '.';
2182 200         1823 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2183              
2184             # P.707 29.2.33. exec
2185             # in Chapter 29: Functions
2186             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2187             #
2188             # As we mentioned earlier, exec treats a discrete list of arguments as an
2189             # indication that it should bypass shell processing. However, there is one
2190             # place where you might still get tripped up. The exec call (and system, too)
2191             # will not distinguish between a single scalar argument and an array containing
2192             # only one element.
2193             #
2194             # @args = ("echo surprise"); # just one element in list
2195             # exec @args # still subject to shell escapes
2196             # or die "exec: $!"; # because @args == 1
2197             #
2198             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2199             # first argument as the pathname, which forces the rest of the arguments to be
2200             # interpreted as a list, even if there is only one of them:
2201             #
2202             # exec { $args[0] } @args # safe even with one-argument list
2203             # or die "can't exec @args: $!";
2204              
2205             # P.855 exec
2206             # in Chapter 27: Functions
2207             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2208             #
2209             # As we mentioned earlier, exec treats a discrete list of arguments as a
2210             # directive to bypass shell processing. However, there is one place where
2211             # you might still get tripped up. The exec call (and system, too) cannot
2212             # distinguish between a single scalar argument and an array containing
2213             # only one element.
2214             #
2215             # @args = ("echo surprise"); # just one element in list
2216             # exec @args # still subject to shell escapes
2217             # || die "exec: $!"; # because @args == 1
2218             #
2219             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2220             # argument as the pathname, which forces the rest of the arguments to be
2221             # interpreted as a list, even if there is only one of them:
2222             #
2223             # exec { $args[0] } @args # safe even with one-argument list
2224             # || die "can't exec @args: $!";
2225              
2226 200         361 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         17577692  
2227             }
2228              
2229             #
2230             # Latin-5 order to character (with parameter)
2231             #
2232             sub Elatin5::chr(;$) {
2233              
2234 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2235              
2236 0 0       0 if ($c == 0x00) {
2237 0         0 return "\x00";
2238             }
2239             else {
2240 0         0 my @chr = ();
2241 0         0 while ($c > 0) {
2242 0         0 unshift @chr, ($c % 0x100);
2243 0         0 $c = int($c / 0x100);
2244             }
2245 0         0 return pack 'C*', @chr;
2246             }
2247             }
2248              
2249             #
2250             # Latin-5 order to character (without parameter)
2251             #
2252             sub Elatin5::chr_() {
2253              
2254 0     0 0 0 my $c = $_;
2255              
2256 0 0       0 if ($c == 0x00) {
2257 0         0 return "\x00";
2258             }
2259             else {
2260 0         0 my @chr = ();
2261 0         0 while ($c > 0) {
2262 0         0 unshift @chr, ($c % 0x100);
2263 0         0 $c = int($c / 0x100);
2264             }
2265 0         0 return pack 'C*', @chr;
2266             }
2267             }
2268              
2269             #
2270             # Latin-5 path globbing (with parameter)
2271             #
2272             sub Elatin5::glob($) {
2273              
2274 0 0   0 0 0 if (wantarray) {
2275 0         0 my @glob = _DOS_like_glob(@_);
2276 0         0 for my $glob (@glob) {
2277 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2278             }
2279 0         0 return @glob;
2280             }
2281             else {
2282 0         0 my $glob = _DOS_like_glob(@_);
2283 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2284 0         0 return $glob;
2285             }
2286             }
2287              
2288             #
2289             # Latin-5 path globbing (without parameter)
2290             #
2291             sub Elatin5::glob_() {
2292              
2293 0 0   0 0 0 if (wantarray) {
2294 0         0 my @glob = _DOS_like_glob();
2295 0         0 for my $glob (@glob) {
2296 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2297             }
2298 0         0 return @glob;
2299             }
2300             else {
2301 0         0 my $glob = _DOS_like_glob();
2302 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2303 0         0 return $glob;
2304             }
2305             }
2306              
2307             #
2308             # Latin-5 path globbing via File::DosGlob 1.10
2309             #
2310             # Often I confuse "_dosglob" and "_doglob".
2311             # So, I renamed "_dosglob" to "_DOS_like_glob".
2312             #
2313             my %iter;
2314             my %entries;
2315             sub _DOS_like_glob {
2316              
2317             # context (keyed by second cxix argument provided by core)
2318 0     0   0 my($expr,$cxix) = @_;
2319              
2320             # glob without args defaults to $_
2321 0 0       0 $expr = $_ if not defined $expr;
2322              
2323             # represents the current user's home directory
2324             #
2325             # 7.3. Expanding Tildes in Filenames
2326             # in Chapter 7. File Access
2327             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2328             #
2329             # and File::HomeDir, File::HomeDir::Windows module
2330              
2331             # DOS-like system
2332 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2333 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2334 0         0 { my_home_MSWin32() }oxmse;
2335             }
2336              
2337             # UNIX-like system
2338             else {
2339 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2340 0 0 0     0 { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2341             }
2342              
2343             # assume global context if not provided one
2344 0 0       0 $cxix = '_G_' if not defined $cxix;
2345 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2346              
2347             # if we're just beginning, do it all first
2348 0 0       0 if ($iter{$cxix} == 0) {
2349 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2350             }
2351              
2352             # chuck it all out, quick or slow
2353 0 0       0 if (wantarray) {
2354 0         0 delete $iter{$cxix};
2355 0         0 return @{delete $entries{$cxix}};
  0         0  
2356             }
2357             else {
2358 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2359 0         0 return shift @{$entries{$cxix}};
  0         0  
2360             }
2361             else {
2362             # return undef for EOL
2363 0         0 delete $iter{$cxix};
2364 0         0 delete $entries{$cxix};
2365 0         0 return undef;
2366             }
2367             }
2368             }
2369              
2370             #
2371             # Latin-5 path globbing subroutine
2372             #
2373             sub _do_glob {
2374              
2375 0     0   0 my($cond,@expr) = @_;
2376 0         0 my @glob = ();
2377 0         0 my $fix_drive_relative_paths = 0;
2378              
2379             OUTER:
2380 0         0 for my $expr (@expr) {
2381 0 0       0 next OUTER if not defined $expr;
2382 0 0       0 next OUTER if $expr eq '';
2383              
2384 0         0 my @matched = ();
2385 0         0 my @globdir = ();
2386 0         0 my $head = '.';
2387 0         0 my $pathsep = '/';
2388 0         0 my $tail;
2389              
2390             # if argument is within quotes strip em and do no globbing
2391 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2392 0         0 $expr = $1;
2393 0 0       0 if ($cond eq 'd') {
2394 0 0       0 if (-d $expr) {
2395 0         0 push @glob, $expr;
2396             }
2397             }
2398             else {
2399 0 0       0 if (-e $expr) {
2400 0         0 push @glob, $expr;
2401             }
2402             }
2403 0         0 next OUTER;
2404             }
2405              
2406             # wildcards with a drive prefix such as h:*.pm must be changed
2407             # to h:./*.pm to expand correctly
2408 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2409 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2410 0         0 $fix_drive_relative_paths = 1;
2411             }
2412             }
2413              
2414 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2415 0 0       0 if ($tail eq '') {
2416 0         0 push @glob, $expr;
2417 0         0 next OUTER;
2418             }
2419 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2420 0 0       0 if (@globdir = _do_glob('d', $head)) {
2421 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2422 0         0 next OUTER;
2423             }
2424             }
2425 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2426 0         0 $head .= $pathsep;
2427             }
2428 0         0 $expr = $tail;
2429             }
2430              
2431             # If file component has no wildcards, we can avoid opendir
2432 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2433 0 0       0 if ($head eq '.') {
2434 0         0 $head = '';
2435             }
2436 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2437 0         0 $head .= $pathsep;
2438             }
2439 0         0 $head .= $expr;
2440 0 0       0 if ($cond eq 'd') {
2441 0 0       0 if (-d $head) {
2442 0         0 push @glob, $head;
2443             }
2444             }
2445             else {
2446 0 0       0 if (-e $head) {
2447 0         0 push @glob, $head;
2448             }
2449             }
2450 0         0 next OUTER;
2451             }
2452 0 0       0 opendir(*DIR, $head) or next OUTER;
2453 0         0 my @leaf = readdir DIR;
2454 0         0 closedir DIR;
2455              
2456 0 0       0 if ($head eq '.') {
2457 0         0 $head = '';
2458             }
2459 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2460 0         0 $head .= $pathsep;
2461             }
2462              
2463 0         0 my $pattern = '';
2464 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2465 0         0 my $char = $1;
2466              
2467             # 6.9. Matching Shell Globs as Regular Expressions
2468             # in Chapter 6. Pattern Matching
2469             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2470             # (and so on)
2471              
2472 0 0       0 if ($char eq '*') {
    0          
    0          
2473 0         0 $pattern .= "(?:$your_char)*",
2474             }
2475             elsif ($char eq '?') {
2476 0         0 $pattern .= "(?:$your_char)?", # DOS style
2477             # $pattern .= "(?:$your_char)", # UNIX style
2478             }
2479             elsif ((my $fc = Elatin5::fc($char)) ne $char) {
2480 0         0 $pattern .= $fc;
2481             }
2482             else {
2483 0         0 $pattern .= quotemeta $char;
2484             }
2485             }
2486 0     0   0 my $matchsub = sub { Elatin5::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2487              
2488             # if ($@) {
2489             # print STDERR "$0: $@\n";
2490             # next OUTER;
2491             # }
2492              
2493             INNER:
2494 0         0 for my $leaf (@leaf) {
2495 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2496 0         0 next INNER;
2497             }
2498 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2499 0         0 next INNER;
2500             }
2501              
2502 0 0       0 if (&$matchsub($leaf)) {
2503 0         0 push @matched, "$head$leaf";
2504 0         0 next INNER;
2505             }
2506              
2507             # [DOS compatibility special case]
2508             # Failed, add a trailing dot and try again, but only...
2509              
2510 0 0 0     0 if (Elatin5::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2511             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2512             Elatin5::index($pattern,'\\.') != -1 # pattern has a dot.
2513             ) {
2514 0 0       0 if (&$matchsub("$leaf.")) {
2515 0         0 push @matched, "$head$leaf";
2516 0         0 next INNER;
2517             }
2518             }
2519             }
2520 0 0       0 if (@matched) {
2521 0         0 push @glob, @matched;
2522             }
2523             }
2524 0 0       0 if ($fix_drive_relative_paths) {
2525 0         0 for my $glob (@glob) {
2526 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2527             }
2528             }
2529 0         0 return @glob;
2530             }
2531              
2532             #
2533             # Latin-5 parse line
2534             #
2535             sub _parse_line {
2536              
2537 0     0   0 my($line) = @_;
2538              
2539 0         0 $line .= ' ';
2540 0         0 my @piece = ();
2541 0         0 while ($line =~ /
2542             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2543             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2544             /oxmsg
2545             ) {
2546 0 0       0 push @piece, defined($1) ? $1 : $2;
2547             }
2548 0         0 return @piece;
2549             }
2550              
2551             #
2552             # Latin-5 parse path
2553             #
2554             sub _parse_path {
2555              
2556 0     0   0 my($path,$pathsep) = @_;
2557              
2558 0         0 $path .= '/';
2559 0         0 my @subpath = ();
2560 0         0 while ($path =~ /
2561             ((?: [^\/\\] )+?) [\/\\]
2562             /oxmsg
2563             ) {
2564 0         0 push @subpath, $1;
2565             }
2566              
2567 0         0 my $tail = pop @subpath;
2568 0         0 my $head = join $pathsep, @subpath;
2569 0         0 return $head, $tail;
2570             }
2571              
2572             #
2573             # via File::HomeDir::Windows 1.00
2574             #
2575             sub my_home_MSWin32 {
2576              
2577             # A lot of unix people and unix-derived tools rely on
2578             # the ability to overload HOME. We will support it too
2579             # so that they can replace raw HOME calls with File::HomeDir.
2580 0 0 0 0 0 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2581 0         0 return $ENV{'HOME'};
2582             }
2583              
2584             # Do we have a user profile?
2585             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2586 0         0 return $ENV{'USERPROFILE'};
2587             }
2588              
2589             # Some Windows use something like $ENV{'HOME'}
2590             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2591 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2592             }
2593              
2594 0         0 return undef;
2595             }
2596              
2597             #
2598             # via File::HomeDir::Unix 1.00
2599             #
2600             sub my_home {
2601 0     0 0 0 my $home;
2602              
2603 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2604 0         0 $home = $ENV{'HOME'};
2605             }
2606              
2607             # This is from the original code, but I'm guessing
2608             # it means "login directory" and exists on some Unixes.
2609             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2610 0         0 $home = $ENV{'LOGDIR'};
2611             }
2612              
2613             ### More-desperate methods
2614              
2615             # Light desperation on any (Unixish) platform
2616             else {
2617 0         0 $home = CORE::eval q{ (getpwuid($<))[7] };
2618             }
2619              
2620             # On Unix in general, a non-existant home means "no home"
2621             # For example, "nobody"-like users might use /nonexistant
2622 0 0 0     0 if (defined $home and ! -d($home)) {
2623 0         0 $home = undef;
2624             }
2625 0         0 return $home;
2626             }
2627              
2628             #
2629             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2630             #
2631             sub Elatin5::PREMATCH {
2632 0     0 0 0 return $`;
2633             }
2634              
2635             #
2636             # ${^MATCH}, $MATCH, $& the string that matched
2637             #
2638             sub Elatin5::MATCH {
2639 0     0 0 0 return $&;
2640             }
2641              
2642             #
2643             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2644             #
2645             sub Elatin5::POSTMATCH {
2646 0     0 0 0 return $';
2647             }
2648              
2649             #
2650             # Latin-5 character to order (with parameter)
2651             #
2652             sub Latin5::ord(;$) {
2653              
2654 0 0   0 1 0 local $_ = shift if @_;
2655              
2656 0 0       0 if (/\A ($q_char) /oxms) {
2657 0         0 my @ord = unpack 'C*', $1;
2658 0         0 my $ord = 0;
2659 0         0 while (my $o = shift @ord) {
2660 0         0 $ord = $ord * 0x100 + $o;
2661             }
2662 0         0 return $ord;
2663             }
2664             else {
2665 0         0 return CORE::ord $_;
2666             }
2667             }
2668              
2669             #
2670             # Latin-5 character to order (without parameter)
2671             #
2672             sub Latin5::ord_() {
2673              
2674 0 0   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-5 reverse
2689             #
2690             sub Latin5::reverse(@) {
2691              
2692 0 0   0 0 0 if (wantarray) {
2693 0         0 return CORE::reverse @_;
2694             }
2695             else {
2696              
2697             # One of us once cornered Larry in an elevator and asked him what
2698             # problem he was solving with this, but he looked as far off into
2699             # the distance as he could in an elevator and said, "It seemed like
2700             # a good idea at the time."
2701              
2702 0         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2703             }
2704             }
2705              
2706             #
2707             # Latin-5 getc (with parameter, without parameter)
2708             #
2709             sub Latin5::getc(;*@) {
2710              
2711 0     0 0 0 my($package) = caller;
2712 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2713 0 0 0     0 croak 'Too many arguments for Latin5::getc' if @_ and not wantarray;
2714              
2715 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2716 0         0 my $getc = '';
2717 0         0 for my $length ($length[0] .. $length[-1]) {
2718 0         0 $getc .= CORE::getc($fh);
2719 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2720 0 0       0 if ($getc =~ /\A ${Elatin5::dot_s} \z/oxms) {
2721 0 0       0 return wantarray ? ($getc,@_) : $getc;
2722             }
2723             }
2724             }
2725 0 0       0 return wantarray ? ($getc,@_) : $getc;
2726             }
2727              
2728             #
2729             # Latin-5 length by character
2730             #
2731             sub Latin5::length(;$) {
2732              
2733 0 0   0 1 0 local $_ = shift if @_;
2734              
2735 0         0 local @_ = /\G ($q_char) /oxmsg;
2736 0         0 return scalar @_;
2737             }
2738              
2739             #
2740             # Latin-5 substr by character
2741             #
2742             BEGIN {
2743              
2744             # P.232 The lvalue Attribute
2745             # in Chapter 6: Subroutines
2746             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2747              
2748             # P.336 The lvalue Attribute
2749             # in Chapter 7: Subroutines
2750             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2751              
2752             # P.144 8.4 Lvalue subroutines
2753             # in Chapter 8: perlsub: Perl subroutines
2754             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2755              
2756 200 50 0 200 1 115382 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  
2757             # vv----------------------*******
2758             sub Latin5::substr($$;$$) %s {
2759              
2760             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2761              
2762             # If the substring is beyond either end of the string, substr() returns the undefined
2763             # value and produces a warning. When used as an lvalue, specifying a substring that
2764             # is entirely outside the string raises an exception.
2765             # http://perldoc.perl.org/functions/substr.html
2766              
2767             # A return with no argument returns the scalar value undef in scalar context,
2768             # an empty list () in list context, and (naturally) nothing at all in void
2769             # context.
2770              
2771             my $offset = $_[1];
2772             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2773             return;
2774             }
2775              
2776             # substr($string,$offset,$length,$replacement)
2777             if (@_ == 4) {
2778             my(undef,undef,$length,$replacement) = @_;
2779             my $substr = join '', splice(@char, $offset, $length, $replacement);
2780             $_[0] = join '', @char;
2781              
2782             # return $substr; this doesn't work, don't say "return"
2783             $substr;
2784             }
2785              
2786             # substr($string,$offset,$length)
2787             elsif (@_ == 3) {
2788             my(undef,undef,$length) = @_;
2789             my $octet_offset = 0;
2790             my $octet_length = 0;
2791             if ($offset == 0) {
2792             $octet_offset = 0;
2793             }
2794             elsif ($offset > 0) {
2795             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2796             }
2797             else {
2798             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2799             }
2800             if ($length == 0) {
2801             $octet_length = 0;
2802             }
2803             elsif ($length > 0) {
2804             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2805             }
2806             else {
2807             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset, $octet_length);
2810             }
2811              
2812             # substr($string,$offset)
2813             else {
2814             my $octet_offset = 0;
2815             if ($offset == 0) {
2816             $octet_offset = 0;
2817             }
2818             elsif ($offset > 0) {
2819             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2820             }
2821             else {
2822             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2823             }
2824             CORE::substr($_[0], $octet_offset);
2825             }
2826             }
2827             END
2828             }
2829              
2830             #
2831             # Latin-5 index by character
2832             #
2833             sub Latin5::index($$;$) {
2834              
2835 0     0 1 0 my $index;
2836 0 0       0 if (@_ == 3) {
2837 0         0 $index = Elatin5::index($_[0], $_[1], CORE::length(Latin5::substr($_[0], 0, $_[2])));
2838             }
2839             else {
2840 0         0 $index = Elatin5::index($_[0], $_[1]);
2841             }
2842              
2843 0 0       0 if ($index == -1) {
2844 0         0 return -1;
2845             }
2846             else {
2847 0         0 return Latin5::length(CORE::substr $_[0], 0, $index);
2848             }
2849             }
2850              
2851             #
2852             # Latin-5 rindex by character
2853             #
2854             sub Latin5::rindex($$;$) {
2855              
2856 0     0 1 0 my $rindex;
2857 0 0       0 if (@_ == 3) {
2858 0         0 $rindex = Elatin5::rindex($_[0], $_[1], CORE::length(Latin5::substr($_[0], 0, $_[2])));
2859             }
2860             else {
2861 0         0 $rindex = Elatin5::rindex($_[0], $_[1]);
2862             }
2863              
2864 0 0       0 if ($rindex == -1) {
2865 0         0 return -1;
2866             }
2867             else {
2868 0         0 return Latin5::length(CORE::substr $_[0], 0, $rindex);
2869             }
2870             }
2871              
2872             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2873             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2874 200     200   15636 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1670  
  200         346  
  200         13363  
2875              
2876             # ord() to ord() or Latin5::ord()
2877 200     200   11818 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1023  
  200         360  
  200         10418  
2878              
2879             # ord to ord or Latin5::ord_
2880 200     200   11316 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   979  
  200         332  
  200         10385  
2881              
2882             # reverse to reverse or Latin5::reverse
2883 200     200   11288 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   1046  
  200         341  
  200         10775  
2884              
2885             # getc to getc or Latin5::getc
2886 200     200   11166 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   972  
  200         337  
  200         11237  
2887              
2888             # P.1023 Appendix W.9 Multibyte Anchoring
2889             # of ISBN 1-56592-224-7 CJKV Information Processing
2890              
2891             my $anchor = '';
2892              
2893 200     200   11594 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   945  
  200         314  
  200         8713128  
2894              
2895             # regexp of nested parens in qqXX
2896              
2897             # P.340 Matching Nested Constructs with Embedded Code
2898             # in Chapter 7: Perl
2899             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2900              
2901             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2902             [^\\()] |
2903             \( (?{$nest++}) |
2904             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2905             \\ [^c] |
2906             \\c[\x40-\x5F] |
2907             [\x00-\xFF]
2908             }xms;
2909              
2910             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2911             [^\\{}] |
2912             \{ (?{$nest++}) |
2913             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2914             \\ [^c] |
2915             \\c[\x40-\x5F] |
2916             [\x00-\xFF]
2917             }xms;
2918              
2919             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2920             [^\\\[\]] |
2921             \[ (?{$nest++}) |
2922             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2923             \\ [^c] |
2924             \\c[\x40-\x5F] |
2925             [\x00-\xFF]
2926             }xms;
2927              
2928             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2929             [^\\<>] |
2930             \< (?{$nest++}) |
2931             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2932             \\ [^c] |
2933             \\c[\x40-\x5F] |
2934             [\x00-\xFF]
2935             }xms;
2936              
2937             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2938             (?: ::)? (?:
2939             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2940             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2941             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2942             ))
2943             }xms;
2944              
2945             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2946             (?: ::)? (?:
2947             (?>[0-9]+) |
2948             [^a-zA-Z_0-9\[\]] |
2949             ^[A-Z] |
2950             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2951             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2952             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2953             ))
2954             }xms;
2955              
2956             my $qq_substr = qr{(?> Char::substr | Latin5::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2957             }xms;
2958              
2959             # regexp of nested parens in qXX
2960             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2961             [^()] |
2962             \( (?{$nest++}) |
2963             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2964             [\x00-\xFF]
2965             }xms;
2966              
2967             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2968             [^\{\}] |
2969             \{ (?{$nest++}) |
2970             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2971             [\x00-\xFF]
2972             }xms;
2973              
2974             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2975             [^\[\]] |
2976             \[ (?{$nest++}) |
2977             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2978             [\x00-\xFF]
2979             }xms;
2980              
2981             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2982             [^<>] |
2983             \< (?{$nest++}) |
2984             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2985             [\x00-\xFF]
2986             }xms;
2987              
2988             my $matched = '';
2989             my $s_matched = '';
2990              
2991             my $tr_variable = ''; # variable of tr///
2992             my $sub_variable = ''; # variable of s///
2993             my $bind_operator = ''; # =~ or !~
2994              
2995             my @heredoc = (); # here document
2996             my @heredoc_delimiter = ();
2997             my $here_script = ''; # here script
2998              
2999             #
3000             # escape Latin-5 script
3001             #
3002             sub Latin5::escape(;$) {
3003 200 50   200 0 2141 local($_) = $_[0] if @_;
3004              
3005             # P.359 The Study Function
3006             # in Chapter 7: Perl
3007             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3008              
3009 200         411 study $_; # Yes, I studied study yesterday.
3010              
3011             # while all script
3012              
3013             # 6.14. Matching from Where the Last Pattern Left Off
3014             # in Chapter 6. Pattern Matching
3015             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3016             # (and so on)
3017              
3018             # one member of Tag-team
3019             #
3020             # P.128 Start of match (or end of previous match): \G
3021             # P.130 Advanced Use of \G with Perl
3022             # in Chapter 3: Overview of Regular Expression Features and Flavors
3023             # P.255 Use leading anchors
3024             # P.256 Expose ^ and \G at the front expressions
3025             # in Chapter 6: Crafting an Efficient Expression
3026             # P.315 "Tag-team" matching with /gc
3027             # in Chapter 7: Perl
3028             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3029              
3030 200         352 my $e_script = '';
3031 200         901 while (not /\G \z/oxgc) { # member
3032 71710         90990 $e_script .= Latin5::escape_token();
3033             }
3034              
3035 200         2226 return $e_script;
3036             }
3037              
3038             #
3039             # escape Latin-5 token of script
3040             #
3041             sub Latin5::escape_token {
3042              
3043             # \n output here document
3044              
3045 71710     71710 0 66885 my $ignore_modules = join('|', qw(
3046             utf8
3047             bytes
3048             charnames
3049             I18N::Japanese
3050             I18N::Collate
3051             I18N::JExt
3052             File::DosGlob
3053             Wild
3054             Wildcard
3055             Japanese
3056             ));
3057              
3058             # another member of Tag-team
3059             #
3060             # P.315 "Tag-team" matching with /gc
3061             # in Chapter 7: Perl
3062             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3063              
3064 71710 100 100     4074331 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          
3065 12067         10587 my $heredoc = '';
3066 12067 100       22005 if (scalar(@heredoc_delimiter) >= 1) {
3067 150         174 $slash = 'm//';
3068              
3069 150         309 $heredoc = join '', @heredoc;
3070 150         876 @heredoc = ();
3071              
3072             # skip here document
3073 150         271 for my $heredoc_delimiter (@heredoc_delimiter) {
3074 150         1190 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3075             }
3076 150         244 @heredoc_delimiter = ();
3077              
3078 150         185 $here_script = '';
3079             }
3080 12067         37191 return "\n" . $heredoc;
3081             }
3082              
3083             # ignore space, comment
3084 17184         50579 elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3085              
3086             # if (, elsif (, unless (, while (, until (, given (, and when (
3087              
3088             # given, when
3089              
3090             # P.225 The given Statement
3091             # in Chapter 15: Smart Matching and given-when
3092             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3093              
3094             # P.133 The given Statement
3095             # in Chapter 4: Statements and Declarations
3096             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3097              
3098             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3099 1373         1749 $slash = 'm//';
3100 1373         4583 return $1;
3101             }
3102              
3103             # scalar variable ($scalar = ...) =~ tr///;
3104             # scalar variable ($scalar = ...) =~ s///;
3105              
3106             # state
3107              
3108             # P.68 Persistent, Private Variables
3109             # in Chapter 4: Subroutines
3110             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3111              
3112             # P.160 Persistent Lexically Scoped Variables: state
3113             # in Chapter 4: Statements and Declarations
3114             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3115              
3116             # (and so on)
3117              
3118             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3119 85         181 my $e_string = e_string($1);
3120              
3121 85 50       1788 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3122 0         0 $tr_variable = $e_string . e_string($1);
3123 0         0 $bind_operator = $2;
3124 0         0 $slash = 'm//';
3125 0         0 return '';
3126             }
3127             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3128 0         0 $sub_variable = $e_string . e_string($1);
3129 0         0 $bind_operator = $2;
3130 0         0 $slash = 'm//';
3131 0         0 return '';
3132             }
3133             else {
3134 85         104 $slash = 'div';
3135 85         267 return $e_string;
3136             }
3137             }
3138              
3139             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
3140             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3141 4         8 $slash = 'div';
3142 4         16 return q{Elatin5::PREMATCH()};
3143             }
3144              
3145             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
3146             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3147 28         44 $slash = 'div';
3148 28         90 return q{Elatin5::MATCH()};
3149             }
3150              
3151             # $', ${'} --> $', ${'}
3152             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3153 1         3 $slash = 'div';
3154 1         5 return $1;
3155             }
3156              
3157             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
3158             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3159 3         9 $slash = 'div';
3160 3         17 return q{Elatin5::POSTMATCH()};
3161             }
3162              
3163             # scalar variable $scalar =~ tr///;
3164             # scalar variable $scalar =~ s///;
3165             # substr() =~ tr///;
3166             # substr() =~ s///;
3167             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3168 1604         3144 my $scalar = e_string($1);
3169              
3170 1604 100       6752 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3171 1         3 $tr_variable = $scalar;
3172 1         3 $bind_operator = $1;
3173 1         1 $slash = 'm//';
3174 1         6 return '';
3175             }
3176             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3177 61         110 $sub_variable = $scalar;
3178 61         135 $bind_operator = $1;
3179 61         104 $slash = 'm//';
3180 61         241 return '';
3181             }
3182             else {
3183 1542         1735 $slash = 'div';
3184 1542         4205 return $scalar;
3185             }
3186             }
3187              
3188             # end of statement
3189             elsif (/\G ( [,;] ) /oxgc) {
3190 4548         5161 $slash = 'm//';
3191              
3192             # clear tr/// variable
3193 4548         4325 $tr_variable = '';
3194              
3195             # clear s/// variable
3196 4548         3778 $sub_variable = '';
3197              
3198 4548         6366 $bind_operator = '';
3199              
3200 4548         16154 return $1;
3201             }
3202              
3203             # bareword
3204             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3205 0         0 return $1;
3206             }
3207              
3208             # $0 --> $0
3209             elsif (/\G ( \$ 0 ) /oxmsgc) {
3210 2         5 $slash = 'div';
3211 2         8 return $1;
3212             }
3213             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3214 0         0 $slash = 'div';
3215 0         0 return $1;
3216             }
3217              
3218             # $$ --> $$
3219             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3220 1         2 $slash = 'div';
3221 1         3 return $1;
3222             }
3223              
3224             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3225             # $1, $2, $3 --> $1, $2, $3 otherwise
3226             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3227 4         4 $slash = 'div';
3228 4         9 return e_capture($1);
3229             }
3230             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3231 0         0 $slash = 'div';
3232 0         0 return e_capture($1);
3233             }
3234              
3235             # $$foo[ ... ] --> $ $foo->[ ... ]
3236             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3237 0         0 $slash = 'div';
3238 0         0 return e_capture($1.'->'.$2);
3239             }
3240              
3241             # $$foo{ ... } --> $ $foo->{ ... }
3242             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3243 0         0 $slash = 'div';
3244 0         0 return e_capture($1.'->'.$2);
3245             }
3246              
3247             # $$foo
3248             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3249 0         0 $slash = 'div';
3250 0         0 return e_capture($1);
3251             }
3252              
3253             # ${ foo }
3254             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3255 0         0 $slash = 'div';
3256 0         0 return '${' . $1 . '}';
3257             }
3258              
3259             # ${ ... }
3260             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3261 0         0 $slash = 'div';
3262 0         0 return e_capture($1);
3263             }
3264              
3265             # variable or function
3266             # $ @ % & * $ #
3267             elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
3268 42         55 $slash = 'div';
3269 42         122 return $1;
3270             }
3271             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3272             # $ @ # \ ' " / ? ( ) [ ] < >
3273             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3274 60         105 $slash = 'div';
3275 60         258 return $1;
3276             }
3277              
3278             # while ()
3279             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3280 0         0 return $1;
3281             }
3282              
3283             # while () --- glob
3284              
3285             # avoid "Error: Runtime exception" of perl version 5.005_03
3286              
3287             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3288 0         0 return 'while ($_ = Elatin5::glob("' . $1 . '"))';
3289             }
3290              
3291             # while (glob)
3292             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3293 0         0 return 'while ($_ = Elatin5::glob_)';
3294             }
3295              
3296             # while (glob(WILDCARD))
3297             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3298 0         0 return 'while ($_ = Elatin5::glob';
3299             }
3300              
3301             # doit if, doit unless, doit while, doit until, doit for, doit when
3302 241         497 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         1013  
3303              
3304             # subroutines of package Elatin5
3305 19         32 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         69  
3306 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3307 13         19 elsif (/\G \b Latin5::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         49  
3308 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3309 114         137 elsif (/\G \b Latin5::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin5::escape'; }
  114         386  
3310 2         4 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         7  
3311 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::chop'; }
  0         0  
3312 2         5 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
3313 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3314 0         0 elsif (/\G \b Latin5::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin5::index'; }
  0         0  
3315 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::index'; }
  0         0  
3316 2         3 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         6  
3317 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3318 0         0 elsif (/\G \b Latin5::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin5::rindex'; }
  0         0  
3319 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::rindex'; }
  0         0  
3320 1         3 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::lc'; }
  1         2  
3321 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::lcfirst'; }
  0         0  
3322 1         2 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::uc'; }
  1         4  
3323 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::ucfirst'; }
  0         0  
3324 6         10 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::fc'; }
  6         18  
3325              
3326             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3327 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3328 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3329 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3330 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3331 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3332 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3333 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3334              
3335 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3336 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3337 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3338 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3339 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3340 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3341 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  
3342              
3343             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3344 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3345 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3346 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3347 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3348              
3349 2         5 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         7  
3350 2         3 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3351 36         71 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::chr'; }
  36         127  
3352 2         5 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         7  
3353 8         9 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         20  
3354 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin5::glob'; }
  0         0  
3355 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::lc_'; }
  0         0  
3356 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::lcfirst_'; }
  0         0  
3357 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::uc_'; }
  0         0  
3358 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::ucfirst_'; }
  0         0  
3359 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::fc_'; }
  0         0  
3360 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3361              
3362 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3363 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3364 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::chr_'; }
  0         0  
3365 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3366 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3367 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin5::glob_'; }
  0         0  
3368 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3369 8         18 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         30  
3370             # split
3371             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3372 87         133 $slash = 'm//';
3373              
3374 87         118 my $e = '';
3375 87         332 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3376 85         327 $e .= $1;
3377             }
3378              
3379             # end of split
3380 87 100       7197 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin5::split' . $e; }
  2 100       11  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3381              
3382             # split scalar value
3383 1         3 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin5::split' . $e . e_string($1); }
3384              
3385             # split literal space
3386 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin5::split' . $e . qq {qq$1 $2}; }
3387 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3388 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3389 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3390 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3391 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin5::split' . $e . qq{$1qq$2 $3}; }
3392 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin5::split' . $e . qq {q$1 $2}; }
3393 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3394 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3395 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3396 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3397 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin5::split' . $e . qq {$1q$2 $3}; }
3398 10         43 elsif (/\G ' [ ] ' /oxgc) { return 'Elatin5::split' . $e . qq {' '}; }
3399 0         0 elsif (/\G " [ ] " /oxgc) { return 'Elatin5::split' . $e . qq {" "}; }
3400              
3401             # split qq//
3402             elsif (/\G \b (qq) \b /oxgc) {
3403 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3404             else {
3405 0         0 while (not /\G \z/oxgc) {
3406 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3407 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3408 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3409 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3410 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3411 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3412 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3413             }
3414 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3415             }
3416             }
3417              
3418             # split qr//
3419             elsif (/\G \b (qr) \b /oxgc) {
3420 12 50       493 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3421             else {
3422 12         57 while (not /\G \z/oxgc) {
3423 12 50       3510 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3424 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3425 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3426 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3427 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3428 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3429 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3430 12         68 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3431             }
3432 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3433             }
3434             }
3435              
3436             # split q//
3437             elsif (/\G \b (q) \b /oxgc) {
3438 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3439             else {
3440 0         0 while (not /\G \z/oxgc) {
3441 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3442 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3443 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3444 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3445 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3446 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3447 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3448             }
3449 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3450             }
3451             }
3452              
3453             # split m//
3454             elsif (/\G \b (m) \b /oxgc) {
3455 18 50       544 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3456             else {
3457 18         73 while (not /\G \z/oxgc) {
3458 18 50       4040 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3459 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3460 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3461 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3462 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3463 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3464 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3465 18         96 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3466             }
3467 0         0 die __FILE__, ": Search pattern not terminated\n";
3468             }
3469             }
3470              
3471             # split ''
3472             elsif (/\G (\') /oxgc) {
3473 0         0 my $q_string = '';
3474 0         0 while (not /\G \z/oxgc) {
3475 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3476 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3477 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3478 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3479             }
3480 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3481             }
3482              
3483             # split ""
3484             elsif (/\G (\") /oxgc) {
3485 0         0 my $qq_string = '';
3486 0         0 while (not /\G \z/oxgc) {
3487 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3488 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3489 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3490 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3491             }
3492 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3493             }
3494              
3495             # split //
3496             elsif (/\G (\/) /oxgc) {
3497 44         73 my $regexp = '';
3498 44         151 while (not /\G \z/oxgc) {
3499 381 50       1582 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3500 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3501 44         194 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3502 337         792 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3503             }
3504 0         0 die __FILE__, ": Search pattern not terminated\n";
3505             }
3506             }
3507              
3508             # tr/// or y///
3509              
3510             # about [cdsrbB]* (/B modifier)
3511             #
3512             # P.559 appendix C
3513             # of ISBN 4-89052-384-7 Programming perl
3514             # (Japanese title is: Perl puroguramingu)
3515              
3516             elsif (/\G \b ( tr | y ) \b /oxgc) {
3517 3         9 my $ope = $1;
3518              
3519             # $1 $2 $3 $4 $5 $6
3520 3 50       88 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3521 0         0 my @tr = ($tr_variable,$2);
3522 0         0 return e_tr(@tr,'',$4,$6);
3523             }
3524             else {
3525 3         6 my $e = '';
3526 3         12 while (not /\G \z/oxgc) {
3527 3 50       315 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3528             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3529 0         0 my @tr = ($tr_variable,$2);
3530 0         0 while (not /\G \z/oxgc) {
3531 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3532 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3533 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3534 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3535 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3536 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3537             }
3538 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3539             }
3540             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3541 0         0 my @tr = ($tr_variable,$2);
3542 0         0 while (not /\G \z/oxgc) {
3543 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3544 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3545 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3546 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3547 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3548 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3549             }
3550 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3551             }
3552             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3553 0         0 my @tr = ($tr_variable,$2);
3554 0         0 while (not /\G \z/oxgc) {
3555 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3556 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3557 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3558 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3559 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3560 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3561             }
3562 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3563             }
3564             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3565 0         0 my @tr = ($tr_variable,$2);
3566 0         0 while (not /\G \z/oxgc) {
3567 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3568 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3569 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3570 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3571 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3572 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3573             }
3574 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3575             }
3576             # $1 $2 $3 $4 $5 $6
3577             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3578 3         13 my @tr = ($tr_variable,$2);
3579 3         10 return e_tr(@tr,'',$4,$6);
3580             }
3581             }
3582 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3583             }
3584             }
3585              
3586             # qq//
3587             elsif (/\G \b (qq) \b /oxgc) {
3588 2130         3945 my $ope = $1;
3589              
3590             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3591 2130 50       3596 if (/\G (\#) /oxgc) { # qq# #
3592 0         0 my $qq_string = '';
3593 0         0 while (not /\G \z/oxgc) {
3594 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3595 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3596 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3597 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3598             }
3599 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3600             }
3601              
3602             else {
3603 2130         2291 my $e = '';
3604 2130         5120 while (not /\G \z/oxgc) {
3605 2130 50       8640 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3606              
3607             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3608             elsif (/\G (\() /oxgc) { # qq ( )
3609 0         0 my $qq_string = '';
3610 0         0 local $nest = 1;
3611 0         0 while (not /\G \z/oxgc) {
3612 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3613 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3614 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3615             elsif (/\G (\)) /oxgc) {
3616 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3617 0         0 else { $qq_string .= $1; }
3618             }
3619 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3620             }
3621 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3622             }
3623              
3624             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3625             elsif (/\G (\{) /oxgc) { # qq { }
3626 2100         2080 my $qq_string = '';
3627 2100         2539 local $nest = 1;
3628 2100         4437 while (not /\G \z/oxgc) {
3629 82644 100       294390 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1480  
    100          
    100          
    50          
3630 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3631 1103         1364 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         2217  
3632             elsif (/\G (\}) /oxgc) {
3633 3203 100       4477 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         4374  
3634 1103         2604 else { $qq_string .= $1; }
3635             }
3636 77616         157309 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3637             }
3638 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3639             }
3640              
3641             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3642             elsif (/\G (\[) /oxgc) { # qq [ ]
3643 0         0 my $qq_string = '';
3644 0         0 local $nest = 1;
3645 0         0 while (not /\G \z/oxgc) {
3646 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3647 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3648 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3649             elsif (/\G (\]) /oxgc) {
3650 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3651 0         0 else { $qq_string .= $1; }
3652             }
3653 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3654             }
3655 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3656             }
3657              
3658             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3659             elsif (/\G (\<) /oxgc) { # qq < >
3660 30         48 my $qq_string = '';
3661 30         53 local $nest = 1;
3662 30         102 while (not /\G \z/oxgc) {
3663 1166 100       4561 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       55  
    50          
    100          
    50          
3664 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3665 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3666             elsif (/\G (\>) /oxgc) {
3667 30 50       63 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         74  
3668 0         0 else { $qq_string .= $1; }
3669             }
3670 1114         2169 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3671             }
3672 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3673             }
3674              
3675             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3676             elsif (/\G (\S) /oxgc) { # qq * *
3677 0         0 my $delimiter = $1;
3678 0         0 my $qq_string = '';
3679 0         0 while (not /\G \z/oxgc) {
3680 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3681 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3682 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3683 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3684             }
3685 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3686             }
3687             }
3688 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3689             }
3690             }
3691              
3692             # qr//
3693             elsif (/\G \b (qr) \b /oxgc) {
3694 0         0 my $ope = $1;
3695 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3696 0         0 return e_qr($ope,$1,$3,$2,$4);
3697             }
3698             else {
3699 0         0 my $e = '';
3700 0         0 while (not /\G \z/oxgc) {
3701 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3702 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3703 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3704 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3705 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3706 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3707 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3708 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3709             }
3710 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3711             }
3712             }
3713              
3714             # qw//
3715             elsif (/\G \b (qw) \b /oxgc) {
3716 16         39 my $ope = $1;
3717 16 50       66 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3718 0         0 return e_qw($ope,$1,$3,$2);
3719             }
3720             else {
3721 16         25 my $e = '';
3722 16         56 while (not /\G \z/oxgc) {
3723 16 50       140 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3724              
3725 16         66 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3726 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3727              
3728 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3729 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3730              
3731 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3732 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3733              
3734 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3735 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3736              
3737 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3738 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3739             }
3740 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3741             }
3742             }
3743              
3744             # qx//
3745             elsif (/\G \b (qx) \b /oxgc) {
3746 0         0 my $ope = $1;
3747 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3748 0         0 return e_qq($ope,$1,$3,$2);
3749             }
3750             else {
3751 0         0 my $e = '';
3752 0         0 while (not /\G \z/oxgc) {
3753 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3754 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3755 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3756 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3757 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3758 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3759 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3760             }
3761 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3762             }
3763             }
3764              
3765             # q//
3766             elsif (/\G \b (q) \b /oxgc) {
3767 245         698 my $ope = $1;
3768              
3769             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3770              
3771             # avoid "Error: Runtime exception" of perl version 5.005_03
3772             # (and so on)
3773              
3774 245 50       845 if (/\G (\#) /oxgc) { # q# #
3775 0         0 my $q_string = '';
3776 0         0 while (not /\G \z/oxgc) {
3777 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3778 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3779 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3780 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3781             }
3782 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3783             }
3784              
3785             else {
3786 245         436 my $e = '';
3787 245         974 while (not /\G \z/oxgc) {
3788 245 50       2163 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3789              
3790             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3791             elsif (/\G (\() /oxgc) { # q ( )
3792 0         0 my $q_string = '';
3793 0         0 local $nest = 1;
3794 0         0 while (not /\G \z/oxgc) {
3795 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3796 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3797 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3798 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3799             elsif (/\G (\)) /oxgc) {
3800 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3801 0         0 else { $q_string .= $1; }
3802             }
3803 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3804             }
3805 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3806             }
3807              
3808             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3809             elsif (/\G (\{) /oxgc) { # q { }
3810 239         428 my $q_string = '';
3811 239         472 local $nest = 1;
3812 239         861 while (not /\G \z/oxgc) {
3813 3637 50       19492 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3814 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3815 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3816 107         152 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         226  
3817             elsif (/\G (\}) /oxgc) {
3818 346 100       780 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         898  
3819 107         270 else { $q_string .= $1; }
3820             }
3821 3184         7105 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_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3827             elsif (/\G (\[) /oxgc) { # q [ ]
3828 0         0 my $q_string = '';
3829 0         0 local $nest = 1;
3830 0         0 while (not /\G \z/oxgc) {
3831 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3832 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3833 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3834 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3835             elsif (/\G (\]) /oxgc) {
3836 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3837 0         0 else { $q_string .= $1; }
3838             }
3839 0         0 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_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3845             elsif (/\G (\<) /oxgc) { # q < >
3846 5         39 my $q_string = '';
3847 5         36 local $nest = 1;
3848 5         94 while (not /\G \z/oxgc) {
3849 88 50       542 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
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 5 50       22 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         20  
3855 0         0 else { $q_string .= $1; }
3856             }
3857 83         230 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 (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3863             elsif (/\G (\S) /oxgc) { # q * *
3864 1         2 my $delimiter = $1;
3865 1         3 my $q_string = '';
3866 1         3 while (not /\G \z/oxgc) {
3867 14 50       74 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3868 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3869 1         2 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3870 13         23 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3871             }
3872 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3873             }
3874             }
3875 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3876             }
3877             }
3878              
3879             # m//
3880             elsif (/\G \b (m) \b /oxgc) {
3881 209         426 my $ope = $1;
3882 209 50       2106 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3883 0         0 return e_qr($ope,$1,$3,$2,$4);
3884             }
3885             else {
3886 209         282 my $e = '';
3887 209         622 while (not /\G \z/oxgc) {
3888 209 50       14540 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3889 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3890 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3891 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3892 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3893 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3894 10         30 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3895 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3896 199         694 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3897             }
3898 0         0 die __FILE__, ": Search pattern not terminated\n";
3899             }
3900             }
3901              
3902             # s///
3903              
3904             # about [cegimosxpradlunbB]* (/cg modifier)
3905             #
3906             # P.67 Pattern-Matching Operators
3907             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3908              
3909             elsif (/\G \b (s) \b /oxgc) {
3910 97         246 my $ope = $1;
3911              
3912             # $1 $2 $3 $4 $5 $6
3913 97 100       2338 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3914 1         6 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3915             }
3916             else {
3917 96         163 my $e = '';
3918 96         365 while (not /\G \z/oxgc) {
3919 96 50       13819 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3920             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3921 0         0 my @s = ($1,$2,$3);
3922 0         0 while (not /\G \z/oxgc) {
3923 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3924             # $1 $2 $3 $4
3925 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934             }
3935 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3936             }
3937             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3938 0         0 my @s = ($1,$2,$3);
3939 0         0 while (not /\G \z/oxgc) {
3940 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3941             # $1 $2 $3 $4
3942 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951             }
3952 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3953             }
3954             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3955 0         0 my @s = ($1,$2,$3);
3956 0         0 while (not /\G \z/oxgc) {
3957 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3958             # $1 $2 $3 $4
3959 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966             }
3967 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3968             }
3969             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3970 0         0 my @s = ($1,$2,$3);
3971 0         0 while (not /\G \z/oxgc) {
3972 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3973             # $1 $2 $3 $4
3974 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983             }
3984 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3985             }
3986             # $1 $2 $3 $4 $5 $6
3987             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3988 21         85 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3989             }
3990             # $1 $2 $3 $4 $5 $6
3991             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3992 0         0 return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3993             }
3994             # $1 $2 $3 $4 $5 $6
3995             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3996 0         0 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3997             }
3998             # $1 $2 $3 $4 $5 $6
3999             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4000 75         344 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4001             }
4002             }
4003 0         0 die __FILE__, ": Substitution pattern not terminated\n";
4004             }
4005             }
4006              
4007             # require ignore module
4008 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4009 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4010 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4011              
4012             # use strict; --> use strict; no strict qw(refs);
4013 36         377 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4014 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4015 0         0 elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4016              
4017             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4018             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4019 2 50 33     38 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4020 0         0 return "use $1; no strict qw(refs);";
4021             }
4022             else {
4023 2         19 return "use $1;";
4024             }
4025             }
4026             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4027 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4028 0         0 return "use $1; no strict qw(refs);";
4029             }
4030             else {
4031 0         0 return "use $1;";
4032             }
4033             }
4034              
4035             # ignore use module
4036 2         18 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4037 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4038 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4039              
4040             # ignore no module
4041 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4042 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4043 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4044              
4045             # use else
4046 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4047              
4048             # use else
4049 2         12 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4050              
4051             # ''
4052             elsif (/\G (?
4053 841         1287 my $q_string = '';
4054 841         3728 while (not /\G \z/oxgc) {
4055 8209 100       29113 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       14  
    100          
    50          
4056 48         73 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4057 841         1905 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4058 7316         14634 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4059             }
4060 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4061             }
4062              
4063             # ""
4064             elsif (/\G (\") /oxgc) {
4065 1719         2453 my $qq_string = '';
4066 1719         4484 while (not /\G \z/oxgc) {
4067 34184 100       107922 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       210  
    100          
    50          
4068 12         23 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4069 1719         4153 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4070 32386         66278 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4071             }
4072 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4073             }
4074              
4075             # ``
4076             elsif (/\G (\`) /oxgc) {
4077 1         1 my $qx_string = '';
4078 1         4 while (not /\G \z/oxgc) {
4079 19 50       71 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4080 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4081 1         3 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4082 18         28 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4083             }
4084 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4085             }
4086              
4087             # // --- not divide operator (num / num), not defined-or
4088             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4089 452         800 my $regexp = '';
4090 452         1345 while (not /\G \z/oxgc) {
4091 4490 50       17041 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4092 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4093 452         1306 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4094 4038         8676 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4095             }
4096 0         0 die __FILE__, ": Search pattern not terminated\n";
4097             }
4098              
4099             # ?? --- not conditional operator (condition ? then : else)
4100             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4101 0         0 my $regexp = '';
4102 0         0 while (not /\G \z/oxgc) {
4103 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4104 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4105 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4106 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4107             }
4108 0         0 die __FILE__, ": Search pattern not terminated\n";
4109             }
4110              
4111             # <<>> (a safer ARGV)
4112 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4113              
4114             # << (bit shift) --- not here document
4115 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4116              
4117             # <<'HEREDOC'
4118             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4119 72         103 $slash = 'm//';
4120 72         163 my $here_quote = $1;
4121 72         159 my $delimiter = $2;
4122              
4123             # get here document
4124 72 50       149 if ($here_script eq '') {
4125 72         383 $here_script = CORE::substr $_, pos $_;
4126 72         398 $here_script =~ s/.*?\n//oxm;
4127             }
4128 72 50       644 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4129 72         234 push @heredoc, $1 . qq{\n$delimiter\n};
4130 72         125 push @heredoc_delimiter, $delimiter;
4131             }
4132             else {
4133 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4134             }
4135 72         326 return $here_quote;
4136             }
4137              
4138             # <<\HEREDOC
4139              
4140             # P.66 2.6.6. "Here" Documents
4141             # in Chapter 2: Bits and Pieces
4142             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4143              
4144             # P.73 "Here" Documents
4145             # in Chapter 2: Bits and Pieces
4146             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4147              
4148             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4149 0         0 $slash = 'm//';
4150 0         0 my $here_quote = $1;
4151 0         0 my $delimiter = $2;
4152              
4153             # get here document
4154 0 0       0 if ($here_script eq '') {
4155 0         0 $here_script = CORE::substr $_, pos $_;
4156 0         0 $here_script =~ s/.*?\n//oxm;
4157             }
4158 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4159 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4160 0         0 push @heredoc_delimiter, $delimiter;
4161             }
4162             else {
4163 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4164             }
4165 0         0 return $here_quote;
4166             }
4167              
4168             # <<"HEREDOC"
4169             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4170 36         78 $slash = 'm//';
4171 36         125 my $here_quote = $1;
4172 36         527 my $delimiter = $2;
4173              
4174             # get here document
4175 36 50       113 if ($here_script eq '') {
4176 36         302 $here_script = CORE::substr $_, pos $_;
4177 36         250 $here_script =~ s/.*?\n//oxm;
4178             }
4179 36 50       911 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4180 36         119 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4181 36         134 push @heredoc_delimiter, $delimiter;
4182             }
4183             else {
4184 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4185             }
4186 36         177 return $here_quote;
4187             }
4188              
4189             # <
4190             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4191 42         89 $slash = 'm//';
4192 42         102 my $here_quote = $1;
4193 42         89 my $delimiter = $2;
4194              
4195             # get here document
4196 42 50       137 if ($here_script eq '') {
4197 42         353 $here_script = CORE::substr $_, pos $_;
4198 42         372 $here_script =~ s/.*?\n//oxm;
4199             }
4200 42 50       643 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4201 42         145 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4202 42         90 push @heredoc_delimiter, $delimiter;
4203             }
4204             else {
4205 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4206             }
4207 42         209 return $here_quote;
4208             }
4209              
4210             # <<`HEREDOC`
4211             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4212 0         0 $slash = 'm//';
4213 0         0 my $here_quote = $1;
4214 0         0 my $delimiter = $2;
4215              
4216             # get here document
4217 0 0       0 if ($here_script eq '') {
4218 0         0 $here_script = CORE::substr $_, pos $_;
4219 0         0 $here_script =~ s/.*?\n//oxm;
4220             }
4221 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4222 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4223 0         0 push @heredoc_delimiter, $delimiter;
4224             }
4225             else {
4226 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4227             }
4228 0         0 return $here_quote;
4229             }
4230              
4231             # <<= <=> <= < operator
4232             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4233 11         46 return $1;
4234             }
4235              
4236             #
4237             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4238 0         0 return $1;
4239             }
4240              
4241             # --- glob
4242              
4243             # avoid "Error: Runtime exception" of perl version 5.005_03
4244              
4245             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4246 0         0 return 'Elatin5::glob("' . $1 . '")';
4247             }
4248              
4249             # __DATA__
4250 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4251              
4252             # __END__
4253 200         1475 elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4254              
4255             # \cD Control-D
4256              
4257             # P.68 2.6.8. Other Literal Tokens
4258             # in Chapter 2: Bits and Pieces
4259             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4260              
4261             # P.76 Other Literal Tokens
4262             # in Chapter 2: Bits and Pieces
4263             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4264              
4265 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4266              
4267             # \cZ Control-Z
4268 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4269              
4270             # any operator before div
4271             elsif (/\G (
4272             -- | \+\+ |
4273             [\)\}\]]
4274              
4275 4824         6324 ) /oxgc) { $slash = 'div'; return $1; }
  4824         21793  
4276              
4277             # yada-yada or triple-dot operator
4278             elsif (/\G (
4279             \.\.\.
4280              
4281 7         7 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         19  
4282              
4283             # any operator before m//
4284              
4285             # //, //= (defined-or)
4286              
4287             # P.164 Logical Operators
4288             # in Chapter 10: More Control Structures
4289             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4290              
4291             # P.119 C-Style Logical (Short-Circuit) Operators
4292             # in Chapter 3: Unary and Binary Operators
4293             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4294              
4295             # (and so on)
4296              
4297             # ~~
4298              
4299             # P.221 The Smart Match Operator
4300             # in Chapter 15: Smart Matching and given-when
4301             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4302              
4303             # P.112 Smartmatch Operator
4304             # in Chapter 3: Unary and Binary Operators
4305             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4306              
4307             # (and so on)
4308              
4309             elsif (/\G ((?>
4310              
4311             !~~ | !~ | != | ! |
4312             %= | % |
4313             &&= | && | &= | &\.= | &\. | & |
4314             -= | -> | - |
4315             :(?>\s*)= |
4316             : |
4317             <<>> |
4318             <<= | <=> | <= | < |
4319             == | => | =~ | = |
4320             >>= | >> | >= | > |
4321             \*\*= | \*\* | \*= | \* |
4322             \+= | \+ |
4323             \.\. | \.= | \. |
4324             \/\/= | \/\/ |
4325             \/= | \/ |
4326             \? |
4327             \\ |
4328             \^= | \^\.= | \^\. | \^ |
4329             \b x= |
4330             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4331             ~~ | ~\. | ~ |
4332             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4333             \b(?: print )\b |
4334              
4335             [,;\(\{\[]
4336              
4337 8471         10390 )) /oxgc) { $slash = 'm//'; return $1; }
  8471         37620  
4338              
4339             # other any character
4340 14740         17254 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14740         66791  
4341              
4342             # system error
4343             else {
4344 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4345             }
4346             }
4347              
4348             # escape Latin-5 string
4349             sub e_string {
4350 1718     1718 0 3279 my($string) = @_;
4351 1718         1895 my $e_string = '';
4352              
4353 1718         2153 local $slash = 'm//';
4354              
4355             # P.1024 Appendix W.10 Multibyte Processing
4356             # of ISBN 1-56592-224-7 CJKV Information Processing
4357             # (and so on)
4358              
4359 1718         16580 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4360              
4361             # without { ... }
4362 1718 100 66     7878 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4363 1701 50       3615 if ($string !~ /<
4364 1701         4058 return $string;
4365             }
4366             }
4367              
4368             E_STRING_LOOP:
4369 17         54 while ($string !~ /\G \z/oxgc) {
4370 190 50       13410 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          
4371             }
4372              
4373             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin5::PREMATCH()]}
4374 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4375 0         0 $e_string .= q{Elatin5::PREMATCH()};
4376 0         0 $slash = 'div';
4377             }
4378              
4379             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin5::MATCH()]}
4380             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4381 0         0 $e_string .= q{Elatin5::MATCH()};
4382 0         0 $slash = 'div';
4383             }
4384              
4385             # $', ${'} --> $', ${'}
4386             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4387 0         0 $e_string .= $1;
4388 0         0 $slash = 'div';
4389             }
4390              
4391             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin5::POSTMATCH()]}
4392             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4393 0         0 $e_string .= q{Elatin5::POSTMATCH()};
4394 0         0 $slash = 'div';
4395             }
4396              
4397             # bareword
4398             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4399 0         0 $e_string .= $1;
4400 0         0 $slash = 'div';
4401             }
4402              
4403             # $0 --> $0
4404             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4405 0         0 $e_string .= $1;
4406 0         0 $slash = 'div';
4407             }
4408             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4409 0         0 $e_string .= $1;
4410 0         0 $slash = 'div';
4411             }
4412              
4413             # $$ --> $$
4414             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4415 0         0 $e_string .= $1;
4416 0         0 $slash = 'div';
4417             }
4418              
4419             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4420             # $1, $2, $3 --> $1, $2, $3 otherwise
4421             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4422 0         0 $e_string .= e_capture($1);
4423 0         0 $slash = 'div';
4424             }
4425             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4426 0         0 $e_string .= e_capture($1);
4427 0         0 $slash = 'div';
4428             }
4429              
4430             # $$foo[ ... ] --> $ $foo->[ ... ]
4431             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4432 0         0 $e_string .= e_capture($1.'->'.$2);
4433 0         0 $slash = 'div';
4434             }
4435              
4436             # $$foo{ ... } --> $ $foo->{ ... }
4437             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4438 0         0 $e_string .= e_capture($1.'->'.$2);
4439 0         0 $slash = 'div';
4440             }
4441              
4442             # $$foo
4443             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4444 0         0 $e_string .= e_capture($1);
4445 0         0 $slash = 'div';
4446             }
4447              
4448             # ${ foo }
4449             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4450 0         0 $e_string .= '${' . $1 . '}';
4451 0         0 $slash = 'div';
4452             }
4453              
4454             # ${ ... }
4455             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4456 3         10 $e_string .= e_capture($1);
4457 3         14 $slash = 'div';
4458             }
4459              
4460             # variable or function
4461             # $ @ % & * $ #
4462             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) {
4463 7         13 $e_string .= $1;
4464 7         19 $slash = 'div';
4465             }
4466             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4467             # $ @ # \ ' " / ? ( ) [ ] < >
4468             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4469 0         0 $e_string .= $1;
4470 0         0 $slash = 'div';
4471             }
4472              
4473             # subroutines of package Elatin5
4474 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4475 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4476 0         0 elsif ($string =~ /\G \b Latin5::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4477 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4478 0         0 elsif ($string =~ /\G \b Latin5::eval \b /oxgc) { $e_string .= 'eval Latin5::escape'; $slash = 'm//'; }
  0         0  
4479 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4480 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin5::chop'; $slash = 'm//'; }
  0         0  
4481 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4482 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4483 0         0 elsif ($string =~ /\G \b Latin5::index \b /oxgc) { $e_string .= 'Latin5::index'; $slash = 'm//'; }
  0         0  
4484 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin5::index'; $slash = 'm//'; }
  0         0  
4485 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4486 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4487 0         0 elsif ($string =~ /\G \b Latin5::rindex \b /oxgc) { $e_string .= 'Latin5::rindex'; $slash = 'm//'; }
  0         0  
4488 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin5::rindex'; $slash = 'm//'; }
  0         0  
4489 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::lc'; $slash = 'm//'; }
  0         0  
4490 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::lcfirst'; $slash = 'm//'; }
  0         0  
4491 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::uc'; $slash = 'm//'; }
  0         0  
4492 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::ucfirst'; $slash = 'm//'; }
  0         0  
4493 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::fc'; $slash = 'm//'; }
  0         0  
4494              
4495             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4496 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4497 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  
4498 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  
4499 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  
4500 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  
4501 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  
4502 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  
4503              
4504 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4505 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  
4506 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  
4507 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  
4508 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  
4509 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  
4510 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  
4511              
4512             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4513 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4514 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4515 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4516 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4517              
4518 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4519 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4520 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::chr'; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin5::glob'; $slash = 'm//'; }
  0         0  
4524 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin5::lc_'; $slash = 'm//'; }
  0         0  
4525 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin5::lcfirst_'; $slash = 'm//'; }
  0         0  
4526 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin5::uc_'; $slash = 'm//'; }
  0         0  
4527 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin5::ucfirst_'; $slash = 'm//'; }
  0         0  
4528 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin5::fc_'; $slash = 'm//'; }
  0         0  
4529 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4530              
4531 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4532 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4533 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin5::chr_'; $slash = 'm//'; }
  0         0  
4534 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4535 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4536 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin5::glob_'; $slash = 'm//'; }
  0         0  
4537 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4538 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4539             # split
4540             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4541 0         0 $slash = 'm//';
4542              
4543 0         0 my $e = '';
4544 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4545 0         0 $e .= $1;
4546             }
4547              
4548             # end of split
4549 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin5::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          
4550              
4551             # split scalar value
4552 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin5::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4553              
4554             # split literal space
4555 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4556 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4557 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4558 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4559 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4560 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4561 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4562 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4563 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4564 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4565 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4566 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4567 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4568 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin5::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4569              
4570             # split qq//
4571             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4572 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  
4573             else {
4574 0         0 while ($string !~ /\G \z/oxgc) {
4575 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4576 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  
4577 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  
4578 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  
4579 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  
4580 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4581 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  
4582             }
4583 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4584             }
4585             }
4586              
4587             # split qr//
4588             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4589 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  
4590             else {
4591 0         0 while ($string !~ /\G \z/oxgc) {
4592 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4593 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  
4594 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  
4595 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  
4596 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  
4597 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  
4598 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  
4599 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  
4600             }
4601 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4602             }
4603             }
4604              
4605             # split q//
4606             elsif ($string =~ /\G \b (q) \b /oxgc) {
4607 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  
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          
4611 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  
4612 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  
4613 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  
4614 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  
4615 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  
4616 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  
4617             }
4618 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4619             }
4620             }
4621              
4622             # split m//
4623             elsif ($string =~ /\G \b (m) \b /oxgc) {
4624 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  
4625             else {
4626 0         0 while ($string !~ /\G \z/oxgc) {
4627 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4628 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  
4629 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  
4630 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  
4631 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  
4632 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  
4633 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  
4634 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  
4635             }
4636 0         0 die __FILE__, ": Search pattern not terminated\n";
4637             }
4638             }
4639              
4640             # split ''
4641             elsif ($string =~ /\G (\') /oxgc) {
4642 0         0 my $q_string = '';
4643 0         0 while ($string !~ /\G \z/oxgc) {
4644 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4645 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4646 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4647 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4648             }
4649 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4650             }
4651              
4652             # split ""
4653             elsif ($string =~ /\G (\") /oxgc) {
4654 0         0 my $qq_string = '';
4655 0         0 while ($string !~ /\G \z/oxgc) {
4656 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4657 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4658 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4659 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4660             }
4661 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4662             }
4663              
4664             # split //
4665             elsif ($string =~ /\G (\/) /oxgc) {
4666 0         0 my $regexp = '';
4667 0         0 while ($string !~ /\G \z/oxgc) {
4668 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4669 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4670 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4671 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4672             }
4673 0         0 die __FILE__, ": Search pattern not terminated\n";
4674             }
4675             }
4676              
4677             # qq//
4678             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4679 0         0 my $ope = $1;
4680 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4681 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4682             }
4683             else {
4684 0         0 my $e = '';
4685 0         0 while ($string !~ /\G \z/oxgc) {
4686 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4687 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4688 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4689 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4690 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4691 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  
4692             }
4693 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4694             }
4695             }
4696              
4697             # qx//
4698             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4699 0         0 my $ope = $1;
4700 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4701 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4702             }
4703             else {
4704 0         0 my $e = '';
4705 0         0 while ($string !~ /\G \z/oxgc) {
4706 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4707 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4708 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4709 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4710 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4711 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4712 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  
4713             }
4714 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4715             }
4716             }
4717              
4718             # q//
4719             elsif ($string =~ /\G \b (q) \b /oxgc) {
4720 0         0 my $ope = $1;
4721 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4722 0         0 $e_string .= e_q($ope,$1,$3,$2);
4723             }
4724             else {
4725 0         0 my $e = '';
4726 0         0 while ($string !~ /\G \z/oxgc) {
4727 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4728 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4729 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4730 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4731 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4732 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  
4733             }
4734 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4735             }
4736             }
4737              
4738             # ''
4739 0         0 elsif ($string =~ /\G (?
4740              
4741             # ""
4742 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4743              
4744             # ``
4745 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4746              
4747             # <<>> (a safer ARGV)
4748 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4749              
4750             # <<= <=> <= < operator
4751 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4752              
4753             #
4754 0         0 elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4755              
4756             # --- glob
4757             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4758 0         0 $e_string .= 'Elatin5::glob("' . $1 . '")';
4759             }
4760              
4761             # << (bit shift) --- not here document
4762 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4763              
4764             # <<'HEREDOC'
4765             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4766 0         0 $slash = 'm//';
4767 0         0 my $here_quote = $1;
4768 0         0 my $delimiter = $2;
4769              
4770             # get here document
4771 0 0       0 if ($here_script eq '') {
4772 0         0 $here_script = CORE::substr $_, pos $_;
4773 0         0 $here_script =~ s/.*?\n//oxm;
4774             }
4775 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4776 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4777 0         0 push @heredoc_delimiter, $delimiter;
4778             }
4779             else {
4780 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4781             }
4782 0         0 $e_string .= $here_quote;
4783             }
4784              
4785             # <<\HEREDOC
4786             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4787 0         0 $slash = 'm//';
4788 0         0 my $here_quote = $1;
4789 0         0 my $delimiter = $2;
4790              
4791             # get here document
4792 0 0       0 if ($here_script eq '') {
4793 0         0 $here_script = CORE::substr $_, pos $_;
4794 0         0 $here_script =~ s/.*?\n//oxm;
4795             }
4796 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4797 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4798 0         0 push @heredoc_delimiter, $delimiter;
4799             }
4800             else {
4801 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4802             }
4803 0         0 $e_string .= $here_quote;
4804             }
4805              
4806             # <<"HEREDOC"
4807             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4808 0         0 $slash = 'm//';
4809 0         0 my $here_quote = $1;
4810 0         0 my $delimiter = $2;
4811              
4812             # get here document
4813 0 0       0 if ($here_script eq '') {
4814 0         0 $here_script = CORE::substr $_, pos $_;
4815 0         0 $here_script =~ s/.*?\n//oxm;
4816             }
4817 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4818 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4819 0         0 push @heredoc_delimiter, $delimiter;
4820             }
4821             else {
4822 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4823             }
4824 0         0 $e_string .= $here_quote;
4825             }
4826              
4827             # <
4828             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4829 0         0 $slash = 'm//';
4830 0         0 my $here_quote = $1;
4831 0         0 my $delimiter = $2;
4832              
4833             # get here document
4834 0 0       0 if ($here_script eq '') {
4835 0         0 $here_script = CORE::substr $_, pos $_;
4836 0         0 $here_script =~ s/.*?\n//oxm;
4837             }
4838 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4839 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4840 0         0 push @heredoc_delimiter, $delimiter;
4841             }
4842             else {
4843 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4844             }
4845 0         0 $e_string .= $here_quote;
4846             }
4847              
4848             # <<`HEREDOC`
4849             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4850 0         0 $slash = 'm//';
4851 0         0 my $here_quote = $1;
4852 0         0 my $delimiter = $2;
4853              
4854             # get here document
4855 0 0       0 if ($here_script eq '') {
4856 0         0 $here_script = CORE::substr $_, pos $_;
4857 0         0 $here_script =~ s/.*?\n//oxm;
4858             }
4859 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4860 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4861 0         0 push @heredoc_delimiter, $delimiter;
4862             }
4863             else {
4864 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4865             }
4866 0         0 $e_string .= $here_quote;
4867             }
4868              
4869             # any operator before div
4870             elsif ($string =~ /\G (
4871             -- | \+\+ |
4872             [\)\}\]]
4873              
4874 18         29 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         56  
4875              
4876             # yada-yada or triple-dot operator
4877             elsif ($string =~ /\G (
4878             \.\.\.
4879              
4880 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         0  
4881              
4882             # any operator before m//
4883             elsif ($string =~ /\G ((?>
4884              
4885             !~~ | !~ | != | ! |
4886             %= | % |
4887             &&= | && | &= | &\.= | &\. | & |
4888             -= | -> | - |
4889             :(?>\s*)= |
4890             : |
4891             <<>> |
4892             <<= | <=> | <= | < |
4893             == | => | =~ | = |
4894             >>= | >> | >= | > |
4895             \*\*= | \*\* | \*= | \* |
4896             \+= | \+ |
4897             \.\. | \.= | \. |
4898             \/\/= | \/\/ |
4899             \/= | \/ |
4900             \? |
4901             \\ |
4902             \^= | \^\.= | \^\. | \^ |
4903             \b x= |
4904             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4905             ~~ | ~\. | ~ |
4906             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4907             \b(?: print )\b |
4908              
4909             [,;\(\{\[]
4910              
4911 31         41 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         104  
4912              
4913             # other any character
4914 131         353 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4915              
4916             # system error
4917             else {
4918 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4919             }
4920             }
4921              
4922 17         71 return $e_string;
4923             }
4924              
4925             #
4926             # character class
4927             #
4928             sub character_class {
4929 1914     1914 0 2709 my($char,$modifier) = @_;
4930              
4931 1914 100       2762 if ($char eq '.') {
4932 52 100       110 if ($modifier =~ /s/) {
4933 17         36 return '${Elatin5::dot_s}';
4934             }
4935             else {
4936 35         90 return '${Elatin5::dot}';
4937             }
4938             }
4939             else {
4940 1862         2994 return Elatin5::classic_character_class($char);
4941             }
4942             }
4943              
4944             #
4945             # escape capture ($1, $2, $3, ...)
4946             #
4947             sub e_capture {
4948              
4949 212     212 0 932 return join '', '${', $_[0], '}';
4950             }
4951              
4952             #
4953             # escape transliteration (tr/// or y///)
4954             #
4955             sub e_tr {
4956 3     3 0 10 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4957 3         4 my $e_tr = '';
4958 3   50     6 $modifier ||= '';
4959              
4960 3         8 $slash = 'div';
4961              
4962             # quote character class 1
4963 3         5 $charclass = q_tr($charclass);
4964              
4965             # quote character class 2
4966 3         7 $charclass2 = q_tr($charclass2);
4967              
4968             # /b /B modifier
4969 3 50       8 if ($modifier =~ tr/bB//d) {
4970 0 0       0 if ($variable eq '') {
4971 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4972             }
4973             else {
4974 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4975             }
4976             }
4977             else {
4978 3 100       7 if ($variable eq '') {
4979 2         8 $e_tr = qq{Elatin5::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4980             }
4981             else {
4982 1         4 $e_tr = qq{Elatin5::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4983             }
4984             }
4985              
4986             # clear tr/// variable
4987 3         5 $tr_variable = '';
4988 3         3 $bind_operator = '';
4989              
4990 3         18 return $e_tr;
4991             }
4992              
4993             #
4994             # quote for escape transliteration (tr/// or y///)
4995             #
4996             sub q_tr {
4997 6     6 0 7 my($charclass) = @_;
4998              
4999             # quote character class
5000 6 50       13 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5001 6         9 return e_q('', "'", "'", $charclass); # --> q' '
5002             }
5003             elsif ($charclass !~ /\//oxms) {
5004 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
5005             }
5006             elsif ($charclass !~ /\#/oxms) {
5007 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
5008             }
5009             elsif ($charclass !~ /[\<\>]/oxms) {
5010 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
5011             }
5012             elsif ($charclass !~ /[\(\)]/oxms) {
5013 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
5014             }
5015             elsif ($charclass !~ /[\{\}]/oxms) {
5016 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5017             }
5018             else {
5019 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5020 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5021 0         0 return e_q('q', $char, $char, $charclass);
5022             }
5023             }
5024             }
5025              
5026 0         0 return e_q('q', '{', '}', $charclass);
5027             }
5028              
5029             #
5030             # escape q string (q//, '')
5031             #
5032             sub e_q {
5033 1092     1092 0 2078 my($ope,$delimiter,$end_delimiter,$string) = @_;
5034              
5035 1092         1928 $slash = 'div';
5036              
5037 1092         6041 return join '', $ope, $delimiter, $string, $end_delimiter;
5038             }
5039              
5040             #
5041             # escape qq string (qq//, "", qx//, ``)
5042             #
5043             sub e_qq {
5044 3931     3931 0 7023 my($ope,$delimiter,$end_delimiter,$string) = @_;
5045              
5046 3931         4249 $slash = 'div';
5047              
5048 3931         3553 my $left_e = 0;
5049 3931         3220 my $right_e = 0;
5050              
5051             # split regexp
5052 3931         165984 my @char = $string =~ /\G((?>
5053             [^\\\$] |
5054             \\x\{ (?>[0-9A-Fa-f]+) \} |
5055             \\o\{ (?>[0-7]+) \} |
5056             \\N\{ (?>[^0-9\}][^\}]*) \} |
5057             \\ $q_char |
5058             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5059             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5060             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5061             \$ (?>\s* [0-9]+) |
5062             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5063             \$ \$ (?![\w\{]) |
5064             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5065             $q_char
5066             ))/oxmsg;
5067              
5068 3931         15438 for (my $i=0; $i <= $#char; $i++) {
5069              
5070             # "\L\u" --> "\u\L"
5071 111768 50 33     526035 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5072 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5073             }
5074              
5075             # "\U\l" --> "\l\U"
5076             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5077 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5078             }
5079              
5080             # octal escape sequence
5081             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5082 1         4 $char[$i] = Elatin5::octchr($1);
5083             }
5084              
5085             # hexadecimal escape sequence
5086             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5087 1         3 $char[$i] = Elatin5::hexchr($1);
5088             }
5089              
5090             # \N{CHARNAME} --> N{CHARNAME}
5091             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5092 0         0 $char[$i] = $1;
5093             }
5094              
5095 111768 100       1275984 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5096             }
5097              
5098             # \F
5099             #
5100             # P.69 Table 2-6. Translation escapes
5101             # in Chapter 2: Bits and Pieces
5102             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5103             # (and so on)
5104              
5105             # \u \l \U \L \F \Q \E
5106 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5107 484 50       1225 if ($right_e < $left_e) {
5108 0         0 $char[$i] = '\\' . $char[$i];
5109             }
5110             }
5111             elsif ($char[$i] eq '\u') {
5112              
5113             # "STRING @{[ LIST EXPR ]} MORE STRING"
5114              
5115             # P.257 Other Tricks You Can Do with Hard References
5116             # in Chapter 8: References
5117             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5118              
5119             # P.353 Other Tricks You Can Do with Hard References
5120             # in Chapter 8: References
5121             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5122              
5123             # (and so on)
5124              
5125 0         0 $char[$i] = '@{[Elatin5::ucfirst qq<';
5126 0         0 $left_e++;
5127             }
5128             elsif ($char[$i] eq '\l') {
5129 0         0 $char[$i] = '@{[Elatin5::lcfirst qq<';
5130 0         0 $left_e++;
5131             }
5132             elsif ($char[$i] eq '\U') {
5133 0         0 $char[$i] = '@{[Elatin5::uc qq<';
5134 0         0 $left_e++;
5135             }
5136             elsif ($char[$i] eq '\L') {
5137 0         0 $char[$i] = '@{[Elatin5::lc qq<';
5138 0         0 $left_e++;
5139             }
5140             elsif ($char[$i] eq '\F') {
5141 24         26 $char[$i] = '@{[Elatin5::fc qq<';
5142 24         50 $left_e++;
5143             }
5144             elsif ($char[$i] eq '\Q') {
5145 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5146 0         0 $left_e++;
5147             }
5148             elsif ($char[$i] eq '\E') {
5149 24 50       36 if ($right_e < $left_e) {
5150 24         25 $char[$i] = '>]}';
5151 24         51 $right_e++;
5152             }
5153             else {
5154 0         0 $char[$i] = '';
5155             }
5156             }
5157             elsif ($char[$i] eq '\Q') {
5158 0         0 while (1) {
5159 0 0       0 if (++$i > $#char) {
5160 0         0 last;
5161             }
5162 0 0       0 if ($char[$i] eq '\E') {
5163 0         0 last;
5164             }
5165             }
5166             }
5167             elsif ($char[$i] eq '\E') {
5168             }
5169              
5170             # $0 --> $0
5171             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5172             }
5173             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5174             }
5175              
5176             # $$ --> $$
5177             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5178             }
5179              
5180             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5181             # $1, $2, $3 --> $1, $2, $3 otherwise
5182             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5183 205         409 $char[$i] = e_capture($1);
5184             }
5185             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5186 0         0 $char[$i] = e_capture($1);
5187             }
5188              
5189             # $$foo[ ... ] --> $ $foo->[ ... ]
5190             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5191 0         0 $char[$i] = e_capture($1.'->'.$2);
5192             }
5193              
5194             # $$foo{ ... } --> $ $foo->{ ... }
5195             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5196 0         0 $char[$i] = e_capture($1.'->'.$2);
5197             }
5198              
5199             # $$foo
5200             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5201 0         0 $char[$i] = e_capture($1);
5202             }
5203              
5204             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
5205             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5206 44         129 $char[$i] = '@{[Elatin5::PREMATCH()]}';
5207             }
5208              
5209             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
5210             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5211 45         129 $char[$i] = '@{[Elatin5::MATCH()]}';
5212             }
5213              
5214             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
5215             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5216 33         98 $char[$i] = '@{[Elatin5::POSTMATCH()]}';
5217             }
5218              
5219             # ${ foo } --> ${ foo }
5220             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5221             }
5222              
5223             # ${ ... }
5224             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5225 0         0 $char[$i] = e_capture($1);
5226             }
5227             }
5228              
5229             # return string
5230 3931 50       7043 if ($left_e > $right_e) {
5231 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5232             }
5233 3931         38875 return join '', $ope, $delimiter, @char, $end_delimiter;
5234             }
5235              
5236             #
5237             # escape qw string (qw//)
5238             #
5239             sub e_qw {
5240 16     16 0 90 my($ope,$delimiter,$end_delimiter,$string) = @_;
5241              
5242 16         26 $slash = 'div';
5243              
5244             # choice again delimiter
5245 16         225 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         584  
5246 16 50       100 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5247 16         118 return join '', $ope, $delimiter, $string, $end_delimiter;
5248             }
5249             elsif (not $octet{')'}) {
5250 0         0 return join '', $ope, '(', $string, ')';
5251             }
5252             elsif (not $octet{'}'}) {
5253 0         0 return join '', $ope, '{', $string, '}';
5254             }
5255             elsif (not $octet{']'}) {
5256 0         0 return join '', $ope, '[', $string, ']';
5257             }
5258             elsif (not $octet{'>'}) {
5259 0         0 return join '', $ope, '<', $string, '>';
5260             }
5261             else {
5262 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5263 0 0       0 if (not $octet{$char}) {
5264 0         0 return join '', $ope, $char, $string, $char;
5265             }
5266             }
5267             }
5268              
5269             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5270 0         0 my @string = CORE::split(/\s+/, $string);
5271 0         0 for my $string (@string) {
5272 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5273 0         0 for my $octet (@octet) {
5274 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5275 0         0 $octet = '\\' . $1;
5276             }
5277             }
5278 0         0 $string = join '', @octet;
5279             }
5280 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5281             }
5282              
5283             #
5284             # escape here document (<<"HEREDOC", <
5285             #
5286             sub e_heredoc {
5287 78     78 0 331 my($string) = @_;
5288              
5289 78         135 $slash = 'm//';
5290              
5291 78         303 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5292              
5293 78         102 my $left_e = 0;
5294 78         84 my $right_e = 0;
5295              
5296             # split regexp
5297 78         9290 my @char = $string =~ /\G((?>
5298             [^\\\$] |
5299             \\x\{ (?>[0-9A-Fa-f]+) \} |
5300             \\o\{ (?>[0-7]+) \} |
5301             \\N\{ (?>[^0-9\}][^\}]*) \} |
5302             \\ $q_char |
5303             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5304             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5305             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5306             \$ (?>\s* [0-9]+) |
5307             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5308             \$ \$ (?![\w\{]) |
5309             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5310             $q_char
5311             ))/oxmsg;
5312              
5313 78         496 for (my $i=0; $i <= $#char; $i++) {
5314              
5315             # "\L\u" --> "\u\L"
5316 2882 50 33     13150 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5317 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5318             }
5319              
5320             # "\U\l" --> "\l\U"
5321             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5322 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5323             }
5324              
5325             # octal escape sequence
5326             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5327 1         3 $char[$i] = Elatin5::octchr($1);
5328             }
5329              
5330             # hexadecimal escape sequence
5331             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5332 1         2 $char[$i] = Elatin5::hexchr($1);
5333             }
5334              
5335             # \N{CHARNAME} --> N{CHARNAME}
5336             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5337 0         0 $char[$i] = $1;
5338             }
5339              
5340 2882 50       37792 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5341             }
5342              
5343             # \u \l \U \L \F \Q \E
5344 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5345 0 0       0 if ($right_e < $left_e) {
5346 0         0 $char[$i] = '\\' . $char[$i];
5347             }
5348             }
5349             elsif ($char[$i] eq '\u') {
5350 0         0 $char[$i] = '@{[Elatin5::ucfirst qq<';
5351 0         0 $left_e++;
5352             }
5353             elsif ($char[$i] eq '\l') {
5354 0         0 $char[$i] = '@{[Elatin5::lcfirst qq<';
5355 0         0 $left_e++;
5356             }
5357             elsif ($char[$i] eq '\U') {
5358 0         0 $char[$i] = '@{[Elatin5::uc qq<';
5359 0         0 $left_e++;
5360             }
5361             elsif ($char[$i] eq '\L') {
5362 0         0 $char[$i] = '@{[Elatin5::lc qq<';
5363 0         0 $left_e++;
5364             }
5365             elsif ($char[$i] eq '\F') {
5366 0         0 $char[$i] = '@{[Elatin5::fc qq<';
5367 0         0 $left_e++;
5368             }
5369             elsif ($char[$i] eq '\Q') {
5370 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5371 0         0 $left_e++;
5372             }
5373             elsif ($char[$i] eq '\E') {
5374 0 0       0 if ($right_e < $left_e) {
5375 0         0 $char[$i] = '>]}';
5376 0         0 $right_e++;
5377             }
5378             else {
5379 0         0 $char[$i] = '';
5380             }
5381             }
5382             elsif ($char[$i] eq '\Q') {
5383 0         0 while (1) {
5384 0 0       0 if (++$i > $#char) {
5385 0         0 last;
5386             }
5387 0 0       0 if ($char[$i] eq '\E') {
5388 0         0 last;
5389             }
5390             }
5391             }
5392             elsif ($char[$i] eq '\E') {
5393             }
5394              
5395             # $0 --> $0
5396             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5397             }
5398             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5399             }
5400              
5401             # $$ --> $$
5402             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5403             }
5404              
5405             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5406             # $1, $2, $3 --> $1, $2, $3 otherwise
5407             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5408 0         0 $char[$i] = e_capture($1);
5409             }
5410             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5411 0         0 $char[$i] = e_capture($1);
5412             }
5413              
5414             # $$foo[ ... ] --> $ $foo->[ ... ]
5415             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5416 0         0 $char[$i] = e_capture($1.'->'.$2);
5417             }
5418              
5419             # $$foo{ ... } --> $ $foo->{ ... }
5420             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5421 0         0 $char[$i] = e_capture($1.'->'.$2);
5422             }
5423              
5424             # $$foo
5425             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5426 0         0 $char[$i] = e_capture($1);
5427             }
5428              
5429             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
5430             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5431 8         44 $char[$i] = '@{[Elatin5::PREMATCH()]}';
5432             }
5433              
5434             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
5435             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5436 8         45 $char[$i] = '@{[Elatin5::MATCH()]}';
5437             }
5438              
5439             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
5440             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5441 6         42 $char[$i] = '@{[Elatin5::POSTMATCH()]}';
5442             }
5443              
5444             # ${ foo } --> ${ foo }
5445             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5446             }
5447              
5448             # ${ ... }
5449             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5450 0         0 $char[$i] = e_capture($1);
5451             }
5452             }
5453              
5454             # return string
5455 78 50       190 if ($left_e > $right_e) {
5456 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5457             }
5458 78         853 return join '', @char;
5459             }
5460              
5461             #
5462             # escape regexp (m//, qr//)
5463             #
5464             sub e_qr {
5465 651     651 0 1884 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5466 651   100     2320 $modifier ||= '';
5467              
5468 651         1013 $modifier =~ tr/p//d;
5469 651 50       1736 if ($modifier =~ /([adlu])/oxms) {
5470 0         0 my $line = 0;
5471 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5472 0 0       0 if ($filename ne __FILE__) {
5473 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5474 0         0 last;
5475             }
5476             }
5477 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5478             }
5479              
5480 651         914 $slash = 'div';
5481              
5482             # literal null string pattern
5483 651 100       2168 if ($string eq '') {
    100          
5484 8         9 $modifier =~ tr/bB//d;
5485 8         5 $modifier =~ tr/i//d;
5486 8         42 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5487             }
5488              
5489             # /b /B modifier
5490             elsif ($modifier =~ tr/bB//d) {
5491              
5492             # choice again delimiter
5493 2 50       14 if ($delimiter =~ / [\@:] /oxms) {
5494 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5495 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5496 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5497 0         0 $delimiter = '(';
5498 0         0 $end_delimiter = ')';
5499             }
5500             elsif (not $octet{'}'}) {
5501 0         0 $delimiter = '{';
5502 0         0 $end_delimiter = '}';
5503             }
5504             elsif (not $octet{']'}) {
5505 0         0 $delimiter = '[';
5506 0         0 $end_delimiter = ']';
5507             }
5508             elsif (not $octet{'>'}) {
5509 0         0 $delimiter = '<';
5510 0         0 $end_delimiter = '>';
5511             }
5512             else {
5513 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5514 0 0       0 if (not $octet{$char}) {
5515 0         0 $delimiter = $char;
5516 0         0 $end_delimiter = $char;
5517 0         0 last;
5518             }
5519             }
5520             }
5521             }
5522              
5523 2 50 33     11 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5524 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5525             }
5526             else {
5527 2         11 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5528             }
5529             }
5530              
5531 641 100       1582 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5532 641         2584 my $metachar = qr/[\@\\|[\]{^]/oxms;
5533              
5534             # split regexp
5535 641         71841 my @char = $string =~ /\G((?>
5536             [^\\\$\@\[\(] |
5537             \\x (?>[0-9A-Fa-f]{1,2}) |
5538             \\ (?>[0-7]{2,3}) |
5539             \\c [\x40-\x5F] |
5540             \\x\{ (?>[0-9A-Fa-f]+) \} |
5541             \\o\{ (?>[0-7]+) \} |
5542             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5543             \\ $q_char |
5544             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5545             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5546             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5547             [\$\@] $qq_variable |
5548             \$ (?>\s* [0-9]+) |
5549             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5550             \$ \$ (?![\w\{]) |
5551             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5552             \[\^ |
5553             \[\: (?>[a-z]+) :\] |
5554             \[\:\^ (?>[a-z]+) :\] |
5555             \(\? |
5556             $q_char
5557             ))/oxmsg;
5558              
5559             # choice again delimiter
5560 641 50       3436 if ($delimiter =~ / [\@:] /oxms) {
5561 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5562 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5563 0         0 $delimiter = '(';
5564 0         0 $end_delimiter = ')';
5565             }
5566             elsif (not $octet{'}'}) {
5567 0         0 $delimiter = '{';
5568 0         0 $end_delimiter = '}';
5569             }
5570             elsif (not $octet{']'}) {
5571 0         0 $delimiter = '[';
5572 0         0 $end_delimiter = ']';
5573             }
5574             elsif (not $octet{'>'}) {
5575 0         0 $delimiter = '<';
5576 0         0 $end_delimiter = '>';
5577             }
5578             else {
5579 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5580 0 0       0 if (not $octet{$char}) {
5581 0         0 $delimiter = $char;
5582 0         0 $end_delimiter = $char;
5583 0         0 last;
5584             }
5585             }
5586             }
5587             }
5588              
5589 641         823 my $left_e = 0;
5590 641         744 my $right_e = 0;
5591 641         1917 for (my $i=0; $i <= $#char; $i++) {
5592              
5593             # "\L\u" --> "\u\L"
5594 1867 50 66     12377 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5595 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5596             }
5597              
5598             # "\U\l" --> "\l\U"
5599             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5600 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5601             }
5602              
5603             # octal escape sequence
5604             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5605 1         3 $char[$i] = Elatin5::octchr($1);
5606             }
5607              
5608             # hexadecimal escape sequence
5609             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5610 1         4 $char[$i] = Elatin5::hexchr($1);
5611             }
5612              
5613             # \b{...} --> b\{...}
5614             # \B{...} --> B\{...}
5615             # \N{CHARNAME} --> N\{CHARNAME}
5616             # \p{PROPERTY} --> p\{PROPERTY}
5617             # \P{PROPERTY} --> P\{PROPERTY}
5618             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5619 6         19 $char[$i] = $1 . '\\' . $2;
5620             }
5621              
5622             # \p, \P, \X --> p, P, X
5623             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5624 4         11 $char[$i] = $1;
5625             }
5626              
5627 1867 100 100     6311 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          
5628             }
5629              
5630             # join separated multiple-octet
5631 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5632 6 50 33     257 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        
5633 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
5634             }
5635             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)) {
5636 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
5637             }
5638             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)) {
5639 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
5640             }
5641             }
5642              
5643             # open character class [...]
5644             elsif ($char[$i] eq '[') {
5645 328         401 my $left = $i;
5646              
5647             # [] make die "Unmatched [] in regexp ...\n"
5648             # (and so on)
5649              
5650 328 100       935 if ($char[$i+1] eq ']') {
5651 3         7 $i++;
5652             }
5653              
5654 328         318 while (1) {
5655 1379 50       1904 if (++$i > $#char) {
5656 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5657             }
5658 1379 100       2229 if ($char[$i] eq ']') {
5659 328         387 my $right = $i;
5660              
5661             # [...]
5662 328 100       1977 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5663 30         73 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         136  
5664             }
5665             else {
5666 298         1237 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
5667             }
5668              
5669 328         483 $i = $left;
5670 328         950 last;
5671             }
5672             }
5673             }
5674              
5675             # open character class [^...]
5676             elsif ($char[$i] eq '[^') {
5677 74         105 my $left = $i;
5678              
5679             # [^] make die "Unmatched [] in regexp ...\n"
5680             # (and so on)
5681              
5682 74 100       210 if ($char[$i+1] eq ']') {
5683 4         8 $i++;
5684             }
5685              
5686 74         88 while (1) {
5687 272 50       533 if (++$i > $#char) {
5688 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5689             }
5690 272 100       574 if ($char[$i] eq ']') {
5691 74         93 my $right = $i;
5692              
5693             # [^...]
5694 74 100       545 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5695 30         109 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         192  
5696             }
5697             else {
5698 44         220 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5699             }
5700              
5701 74         132 $i = $left;
5702 74         274 last;
5703             }
5704             }
5705             }
5706              
5707             # rewrite character class or escape character
5708             elsif (my $char = character_class($char[$i],$modifier)) {
5709 139         544 $char[$i] = $char;
5710             }
5711              
5712             # /i modifier
5713             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
5714 20 50       31 if (CORE::length(Elatin5::fc($char[$i])) == 1) {
5715 20         33 $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
5716             }
5717             else {
5718 0         0 $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
5719             }
5720             }
5721              
5722             # \u \l \U \L \F \Q \E
5723             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5724 1 50       5 if ($right_e < $left_e) {
5725 0         0 $char[$i] = '\\' . $char[$i];
5726             }
5727             }
5728             elsif ($char[$i] eq '\u') {
5729 0         0 $char[$i] = '@{[Elatin5::ucfirst qq<';
5730 0         0 $left_e++;
5731             }
5732             elsif ($char[$i] eq '\l') {
5733 0         0 $char[$i] = '@{[Elatin5::lcfirst qq<';
5734 0         0 $left_e++;
5735             }
5736             elsif ($char[$i] eq '\U') {
5737 1         3 $char[$i] = '@{[Elatin5::uc qq<';
5738 1         8 $left_e++;
5739             }
5740             elsif ($char[$i] eq '\L') {
5741 1         3 $char[$i] = '@{[Elatin5::lc qq<';
5742 1         7 $left_e++;
5743             }
5744             elsif ($char[$i] eq '\F') {
5745 18         23 $char[$i] = '@{[Elatin5::fc qq<';
5746 18         87 $left_e++;
5747             }
5748             elsif ($char[$i] eq '\Q') {
5749 1         4 $char[$i] = '@{[CORE::quotemeta qq<';
5750 1         8 $left_e++;
5751             }
5752             elsif ($char[$i] eq '\E') {
5753 21 50       50 if ($right_e < $left_e) {
5754 21         25 $char[$i] = '>]}';
5755 21         89 $right_e++;
5756             }
5757             else {
5758 0         0 $char[$i] = '';
5759             }
5760             }
5761             elsif ($char[$i] eq '\Q') {
5762 0         0 while (1) {
5763 0 0       0 if (++$i > $#char) {
5764 0         0 last;
5765             }
5766 0 0       0 if ($char[$i] eq '\E') {
5767 0         0 last;
5768             }
5769             }
5770             }
5771             elsif ($char[$i] eq '\E') {
5772             }
5773              
5774             # $0 --> $0
5775             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5776 0 0       0 if ($ignorecase) {
5777 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5778             }
5779             }
5780             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5781 0 0       0 if ($ignorecase) {
5782 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5783             }
5784             }
5785              
5786             # $$ --> $$
5787             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5788             }
5789              
5790             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5791             # $1, $2, $3 --> $1, $2, $3 otherwise
5792             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5793 0         0 $char[$i] = e_capture($1);
5794 0 0       0 if ($ignorecase) {
5795 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5796             }
5797             }
5798             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5799 0         0 $char[$i] = e_capture($1);
5800 0 0       0 if ($ignorecase) {
5801 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5802             }
5803             }
5804              
5805             # $$foo[ ... ] --> $ $foo->[ ... ]
5806             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5807 0         0 $char[$i] = e_capture($1.'->'.$2);
5808 0 0       0 if ($ignorecase) {
5809 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5810             }
5811             }
5812              
5813             # $$foo{ ... } --> $ $foo->{ ... }
5814             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5815 0         0 $char[$i] = e_capture($1.'->'.$2);
5816 0 0       0 if ($ignorecase) {
5817 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5818             }
5819             }
5820              
5821             # $$foo
5822             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5823 0         0 $char[$i] = e_capture($1);
5824 0 0       0 if ($ignorecase) {
5825 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5826             }
5827             }
5828              
5829             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
5830             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5831 8 50       18 if ($ignorecase) {
5832 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
5833             }
5834             else {
5835 8         37 $char[$i] = '@{[Elatin5::PREMATCH()]}';
5836             }
5837             }
5838              
5839             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
5840             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5841 8 50       22 if ($ignorecase) {
5842 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
5843             }
5844             else {
5845 8         41 $char[$i] = '@{[Elatin5::MATCH()]}';
5846             }
5847             }
5848              
5849             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
5850             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5851 6 50       20 if ($ignorecase) {
5852 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
5853             }
5854             else {
5855 6         39 $char[$i] = '@{[Elatin5::POSTMATCH()]}';
5856             }
5857             }
5858              
5859             # ${ foo }
5860             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5861 0 0       0 if ($ignorecase) {
5862 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5863             }
5864             }
5865              
5866             # ${ ... }
5867             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5868 0         0 $char[$i] = e_capture($1);
5869 0 0       0 if ($ignorecase) {
5870 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5871             }
5872             }
5873              
5874             # $scalar or @array
5875             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5876 21         43 $char[$i] = e_string($char[$i]);
5877 21 100       78 if ($ignorecase) {
5878 11         54 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
5879             }
5880             }
5881              
5882             # quote character before ? + * {
5883             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5884 138 100 33     1248 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5885             }
5886             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5887 0         0 my $char = $char[$i-1];
5888 0 0       0 if ($char[$i] eq '{') {
5889 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5890             }
5891             else {
5892 0         0 die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5893             }
5894             }
5895             else {
5896 127         897 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5897             }
5898             }
5899             }
5900              
5901             # make regexp string
5902 641         937 $modifier =~ tr/i//d;
5903 641 50       1392 if ($left_e > $right_e) {
5904 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5905 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5906             }
5907             else {
5908 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5909             }
5910             }
5911 641 50 33     4086 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5912 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5913             }
5914             else {
5915 641         5762 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5916             }
5917             }
5918              
5919             #
5920             # double quote stuff
5921             #
5922             sub qq_stuff {
5923 180     180 0 235 my($delimiter,$end_delimiter,$stuff) = @_;
5924              
5925             # scalar variable or array variable
5926 180 100       447 if ($stuff =~ /\A [\$\@] /oxms) {
5927 100         469 return $stuff;
5928             }
5929              
5930             # quote by delimiter
5931 80         234 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         296  
5932 80         242 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5933 80 50       170 next if $char eq $delimiter;
5934 80 50       149 next if $char eq $end_delimiter;
5935 80 50       195 if (not $octet{$char}) {
5936 80         474 return join '', 'qq', $char, $stuff, $char;
5937             }
5938             }
5939 0         0 return join '', 'qq', '<', $stuff, '>';
5940             }
5941              
5942             #
5943             # escape regexp (m'', qr'', and m''b, qr''b)
5944             #
5945             sub e_qr_q {
5946 10     10 0 30 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5947 10   50     41 $modifier ||= '';
5948              
5949 10         14 $modifier =~ tr/p//d;
5950 10 50       23 if ($modifier =~ /([adlu])/oxms) {
5951 0         0 my $line = 0;
5952 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5953 0 0       0 if ($filename ne __FILE__) {
5954 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5955 0         0 last;
5956             }
5957             }
5958 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5959             }
5960              
5961 10         14 $slash = 'div';
5962              
5963             # literal null string pattern
5964 10 100       26 if ($string eq '') {
    50          
5965 8         10 $modifier =~ tr/bB//d;
5966 8         8 $modifier =~ tr/i//d;
5967 8         49 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5968             }
5969              
5970             # with /b /B modifier
5971             elsif ($modifier =~ tr/bB//d) {
5972 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5973             }
5974              
5975             # without /b /B modifier
5976             else {
5977 2         7 return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5978             }
5979             }
5980              
5981             #
5982             # escape regexp (m'', qr'')
5983             #
5984             sub e_qr_qt {
5985 2     2 0 6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5986              
5987 2 50       5 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5988              
5989             # split regexp
5990 2         74 my @char = $string =~ /\G((?>
5991             [^\\\[\$\@\/] |
5992             [\x00-\xFF] |
5993             \[\^ |
5994             \[\: (?>[a-z]+) \:\] |
5995             \[\:\^ (?>[a-z]+) \:\] |
5996             [\$\@\/] |
5997             \\ (?:$q_char) |
5998             (?:$q_char)
5999             ))/oxmsg;
6000              
6001             # unescape character
6002 2         12 for (my $i=0; $i <= $#char; $i++) {
6003 2 50 33     21 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
6004             }
6005              
6006             # open character class [...]
6007 0         0 elsif ($char[$i] eq '[') {
6008 0         0 my $left = $i;
6009 0 0       0 if ($char[$i+1] eq ']') {
6010 0         0 $i++;
6011             }
6012 0         0 while (1) {
6013 0 0       0 if (++$i > $#char) {
6014 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6015             }
6016 0 0       0 if ($char[$i] eq ']') {
6017 0         0 my $right = $i;
6018              
6019             # [...]
6020 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6021              
6022 0         0 $i = $left;
6023 0         0 last;
6024             }
6025             }
6026             }
6027              
6028             # open character class [^...]
6029             elsif ($char[$i] eq '[^') {
6030 0         0 my $left = $i;
6031 0 0       0 if ($char[$i+1] eq ']') {
6032 0         0 $i++;
6033             }
6034 0         0 while (1) {
6035 0 0       0 if (++$i > $#char) {
6036 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6037             }
6038 0 0       0 if ($char[$i] eq ']') {
6039 0         0 my $right = $i;
6040              
6041             # [^...]
6042 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6043              
6044 0         0 $i = $left;
6045 0         0 last;
6046             }
6047             }
6048             }
6049              
6050             # escape $ @ / and \
6051             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6052 0         0 $char[$i] = '\\' . $char[$i];
6053             }
6054              
6055             # rewrite character class or escape character
6056             elsif (my $char = character_class($char[$i],$modifier)) {
6057 0         0 $char[$i] = $char;
6058             }
6059              
6060             # /i modifier
6061             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6062 0 0       0 if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6063 0         0 $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6064             }
6065             else {
6066 0         0 $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6067             }
6068             }
6069              
6070             # quote character before ? + * {
6071             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6072 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6073             }
6074             else {
6075 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6076             }
6077             }
6078             }
6079              
6080 2         3 $delimiter = '/';
6081 2         3 $end_delimiter = '/';
6082              
6083 2         4 $modifier =~ tr/i//d;
6084 2         16 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6085             }
6086              
6087             #
6088             # escape regexp (m''b, qr''b)
6089             #
6090             sub e_qr_qb {
6091 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6092              
6093             # split regexp
6094 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6095              
6096             # unescape character
6097 0         0 for (my $i=0; $i <= $#char; $i++) {
6098 0 0       0 if (0) {
    0          
6099             }
6100              
6101             # remain \\
6102 0         0 elsif ($char[$i] eq '\\\\') {
6103             }
6104              
6105             # escape $ @ / and \
6106             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6107 0         0 $char[$i] = '\\' . $char[$i];
6108             }
6109             }
6110              
6111 0         0 $delimiter = '/';
6112 0         0 $end_delimiter = '/';
6113 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6114             }
6115              
6116             #
6117             # escape regexp (s/here//)
6118             #
6119             sub e_s1 {
6120 76     76 0 189 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6121 76   100     306 $modifier ||= '';
6122              
6123 76         113 $modifier =~ tr/p//d;
6124 76 50       253 if ($modifier =~ /([adlu])/oxms) {
6125 0         0 my $line = 0;
6126 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6127 0 0       0 if ($filename ne __FILE__) {
6128 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6129 0         0 last;
6130             }
6131             }
6132 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6133             }
6134              
6135 76         152 $slash = 'div';
6136              
6137             # literal null string pattern
6138 76 100       326 if ($string eq '') {
    50          
6139 8         9 $modifier =~ tr/bB//d;
6140 8         8 $modifier =~ tr/i//d;
6141 8         57 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6142             }
6143              
6144             # /b /B modifier
6145             elsif ($modifier =~ tr/bB//d) {
6146              
6147             # choice again delimiter
6148 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
6149 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6150 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6151 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6152 0         0 $delimiter = '(';
6153 0         0 $end_delimiter = ')';
6154             }
6155             elsif (not $octet{'}'}) {
6156 0         0 $delimiter = '{';
6157 0         0 $end_delimiter = '}';
6158             }
6159             elsif (not $octet{']'}) {
6160 0         0 $delimiter = '[';
6161 0         0 $end_delimiter = ']';
6162             }
6163             elsif (not $octet{'>'}) {
6164 0         0 $delimiter = '<';
6165 0         0 $end_delimiter = '>';
6166             }
6167             else {
6168 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6169 0 0       0 if (not $octet{$char}) {
6170 0         0 $delimiter = $char;
6171 0         0 $end_delimiter = $char;
6172 0         0 last;
6173             }
6174             }
6175             }
6176             }
6177              
6178 0         0 my $prematch = '';
6179 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6180             }
6181              
6182 68 100       209 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6183 68         317 my $metachar = qr/[\@\\|[\]{^]/oxms;
6184              
6185             # split regexp
6186 68         18793 my @char = $string =~ /\G((?>
6187             [^\\\$\@\[\(] |
6188             \\ (?>[1-9][0-9]*) |
6189             \\g (?>\s*) (?>[1-9][0-9]*) |
6190             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6191             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6192             \\x (?>[0-9A-Fa-f]{1,2}) |
6193             \\ (?>[0-7]{2,3}) |
6194             \\c [\x40-\x5F] |
6195             \\x\{ (?>[0-9A-Fa-f]+) \} |
6196             \\o\{ (?>[0-7]+) \} |
6197             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6198             \\ $q_char |
6199             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6200             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6201             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6202             [\$\@] $qq_variable |
6203             \$ (?>\s* [0-9]+) |
6204             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6205             \$ \$ (?![\w\{]) |
6206             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6207             \[\^ |
6208             \[\: (?>[a-z]+) :\] |
6209             \[\:\^ (?>[a-z]+) :\] |
6210             \(\? |
6211             $q_char
6212             ))/oxmsg;
6213              
6214             # choice again delimiter
6215 68 50       606 if ($delimiter =~ / [\@:] /oxms) {
6216 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6217 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6218 0         0 $delimiter = '(';
6219 0         0 $end_delimiter = ')';
6220             }
6221             elsif (not $octet{'}'}) {
6222 0         0 $delimiter = '{';
6223 0         0 $end_delimiter = '}';
6224             }
6225             elsif (not $octet{']'}) {
6226 0         0 $delimiter = '[';
6227 0         0 $end_delimiter = ']';
6228             }
6229             elsif (not $octet{'>'}) {
6230 0         0 $delimiter = '<';
6231 0         0 $end_delimiter = '>';
6232             }
6233             else {
6234 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6235 0 0       0 if (not $octet{$char}) {
6236 0         0 $delimiter = $char;
6237 0         0 $end_delimiter = $char;
6238 0         0 last;
6239             }
6240             }
6241             }
6242             }
6243              
6244             # count '('
6245 68         136 my $parens = grep { $_ eq '(' } @char;
  253         472  
6246              
6247 68         89 my $left_e = 0;
6248 68         91 my $right_e = 0;
6249 68         256 for (my $i=0; $i <= $#char; $i++) {
6250              
6251             # "\L\u" --> "\u\L"
6252 195 50 33     1584 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6253 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6254             }
6255              
6256             # "\U\l" --> "\l\U"
6257             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6258 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6259             }
6260              
6261             # octal escape sequence
6262             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6263 1         3 $char[$i] = Elatin5::octchr($1);
6264             }
6265              
6266             # hexadecimal escape sequence
6267             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6268 1         3 $char[$i] = Elatin5::hexchr($1);
6269             }
6270              
6271             # \b{...} --> b\{...}
6272             # \B{...} --> B\{...}
6273             # \N{CHARNAME} --> N\{CHARNAME}
6274             # \p{PROPERTY} --> p\{PROPERTY}
6275             # \P{PROPERTY} --> P\{PROPERTY}
6276             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6277 0         0 $char[$i] = $1 . '\\' . $2;
6278             }
6279              
6280             # \p, \P, \X --> p, P, X
6281             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6282 0         0 $char[$i] = $1;
6283             }
6284              
6285 195 50 66     861 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          
6286             }
6287              
6288             # join separated multiple-octet
6289 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6290 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        
6291 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
6292             }
6293             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)) {
6294 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
6295             }
6296             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)) {
6297 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
6298             }
6299             }
6300              
6301             # open character class [...]
6302             elsif ($char[$i] eq '[') {
6303 13         21 my $left = $i;
6304 13 50       48 if ($char[$i+1] eq ']') {
6305 0         0 $i++;
6306             }
6307 13         18 while (1) {
6308 58 50       87 if (++$i > $#char) {
6309 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6310             }
6311 58 100       102 if ($char[$i] eq ']') {
6312 13         16 my $right = $i;
6313              
6314             # [...]
6315 13 50       98 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6316 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6317             }
6318             else {
6319 13         225 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6320             }
6321              
6322 13         24 $i = $left;
6323 13         42 last;
6324             }
6325             }
6326             }
6327              
6328             # open character class [^...]
6329             elsif ($char[$i] eq '[^') {
6330 0         0 my $left = $i;
6331 0 0       0 if ($char[$i+1] eq ']') {
6332 0         0 $i++;
6333             }
6334 0         0 while (1) {
6335 0 0       0 if (++$i > $#char) {
6336 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6337             }
6338 0 0       0 if ($char[$i] eq ']') {
6339 0         0 my $right = $i;
6340              
6341             # [^...]
6342 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6343 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6344             }
6345             else {
6346 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6347             }
6348              
6349 0         0 $i = $left;
6350 0         0 last;
6351             }
6352             }
6353             }
6354              
6355             # rewrite character class or escape character
6356             elsif (my $char = character_class($char[$i],$modifier)) {
6357 7         23 $char[$i] = $char;
6358             }
6359              
6360             # /i modifier
6361             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6362 3 50       5 if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6363 3         5 $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6364             }
6365             else {
6366 0         0 $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6367             }
6368             }
6369              
6370             # \u \l \U \L \F \Q \E
6371             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6372 0 0       0 if ($right_e < $left_e) {
6373 0         0 $char[$i] = '\\' . $char[$i];
6374             }
6375             }
6376             elsif ($char[$i] eq '\u') {
6377 0         0 $char[$i] = '@{[Elatin5::ucfirst qq<';
6378 0         0 $left_e++;
6379             }
6380             elsif ($char[$i] eq '\l') {
6381 0         0 $char[$i] = '@{[Elatin5::lcfirst qq<';
6382 0         0 $left_e++;
6383             }
6384             elsif ($char[$i] eq '\U') {
6385 0         0 $char[$i] = '@{[Elatin5::uc qq<';
6386 0         0 $left_e++;
6387             }
6388             elsif ($char[$i] eq '\L') {
6389 0         0 $char[$i] = '@{[Elatin5::lc qq<';
6390 0         0 $left_e++;
6391             }
6392             elsif ($char[$i] eq '\F') {
6393 0         0 $char[$i] = '@{[Elatin5::fc qq<';
6394 0         0 $left_e++;
6395             }
6396             elsif ($char[$i] eq '\Q') {
6397 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6398 0         0 $left_e++;
6399             }
6400             elsif ($char[$i] eq '\E') {
6401 0 0       0 if ($right_e < $left_e) {
6402 0         0 $char[$i] = '>]}';
6403 0         0 $right_e++;
6404             }
6405             else {
6406 0         0 $char[$i] = '';
6407             }
6408             }
6409             elsif ($char[$i] eq '\Q') {
6410 0         0 while (1) {
6411 0 0       0 if (++$i > $#char) {
6412 0         0 last;
6413             }
6414 0 0       0 if ($char[$i] eq '\E') {
6415 0         0 last;
6416             }
6417             }
6418             }
6419             elsif ($char[$i] eq '\E') {
6420             }
6421              
6422             # \0 --> \0
6423             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6424             }
6425              
6426             # \g{N}, \g{-N}
6427              
6428             # P.108 Using Simple Patterns
6429             # in Chapter 7: In the World of Regular Expressions
6430             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6431              
6432             # P.221 Capturing
6433             # in Chapter 5: Pattern Matching
6434             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6435              
6436             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6437             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6438             }
6439              
6440             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6441             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6442             }
6443              
6444             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6445             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6446             }
6447              
6448             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6449             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6450             }
6451              
6452             # $0 --> $0
6453             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6454 0 0       0 if ($ignorecase) {
6455 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6456             }
6457             }
6458             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6459 0 0       0 if ($ignorecase) {
6460 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6461             }
6462             }
6463              
6464             # $$ --> $$
6465             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6466             }
6467              
6468             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6469             # $1, $2, $3 --> $1, $2, $3 otherwise
6470             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6471 0         0 $char[$i] = e_capture($1);
6472 0 0       0 if ($ignorecase) {
6473 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6474             }
6475             }
6476             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6477 0         0 $char[$i] = e_capture($1);
6478 0 0       0 if ($ignorecase) {
6479 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6480             }
6481             }
6482              
6483             # $$foo[ ... ] --> $ $foo->[ ... ]
6484             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6485 0         0 $char[$i] = e_capture($1.'->'.$2);
6486 0 0       0 if ($ignorecase) {
6487 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6488             }
6489             }
6490              
6491             # $$foo{ ... } --> $ $foo->{ ... }
6492             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6493 0         0 $char[$i] = e_capture($1.'->'.$2);
6494 0 0       0 if ($ignorecase) {
6495 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6496             }
6497             }
6498              
6499             # $$foo
6500             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6501 0         0 $char[$i] = e_capture($1);
6502 0 0       0 if ($ignorecase) {
6503 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6504             }
6505             }
6506              
6507             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
6508             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6509 4 50       13 if ($ignorecase) {
6510 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
6511             }
6512             else {
6513 4         24 $char[$i] = '@{[Elatin5::PREMATCH()]}';
6514             }
6515             }
6516              
6517             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
6518             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6519 4 50       14 if ($ignorecase) {
6520 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
6521             }
6522             else {
6523 4         24 $char[$i] = '@{[Elatin5::MATCH()]}';
6524             }
6525             }
6526              
6527             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
6528             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6529 3 50       9 if ($ignorecase) {
6530 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
6531             }
6532             else {
6533 3         21 $char[$i] = '@{[Elatin5::POSTMATCH()]}';
6534             }
6535             }
6536              
6537             # ${ foo }
6538             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6539 0 0       0 if ($ignorecase) {
6540 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6541             }
6542             }
6543              
6544             # ${ ... }
6545             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6546 0         0 $char[$i] = e_capture($1);
6547 0 0       0 if ($ignorecase) {
6548 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6549             }
6550             }
6551              
6552             # $scalar or @array
6553             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6554 4         12 $char[$i] = e_string($char[$i]);
6555 4 50       53 if ($ignorecase) {
6556 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
6557             }
6558             }
6559              
6560             # quote character before ? + * {
6561             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6562 13 50       71 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6563             }
6564             else {
6565 13         120 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6566             }
6567             }
6568             }
6569              
6570             # make regexp string
6571 68         139 my $prematch = '';
6572 68         115 $modifier =~ tr/i//d;
6573 68 50       243 if ($left_e > $right_e) {
6574 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6575             }
6576 68         955 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6577             }
6578              
6579             #
6580             # escape regexp (s'here'' or s'here''b)
6581             #
6582             sub e_s1_q {
6583 21     21 0 48 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6584 21   100     82 $modifier ||= '';
6585              
6586 21         30 $modifier =~ tr/p//d;
6587 21 50       53 if ($modifier =~ /([adlu])/oxms) {
6588 0         0 my $line = 0;
6589 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6590 0 0       0 if ($filename ne __FILE__) {
6591 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6592 0         0 last;
6593             }
6594             }
6595 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6596             }
6597              
6598 21         33 $slash = 'div';
6599              
6600             # literal null string pattern
6601 21 100       71 if ($string eq '') {
    50          
6602 8         9 $modifier =~ tr/bB//d;
6603 8         8 $modifier =~ tr/i//d;
6604 8         52 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6605             }
6606              
6607             # with /b /B modifier
6608             elsif ($modifier =~ tr/bB//d) {
6609 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6610             }
6611              
6612             # without /b /B modifier
6613             else {
6614 13         34 return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6615             }
6616             }
6617              
6618             #
6619             # escape regexp (s'here'')
6620             #
6621             sub e_s1_qt {
6622 13     13 0 38 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6623              
6624 13 50       35 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6625              
6626             # split regexp
6627 13         1439 my @char = $string =~ /\G((?>
6628             [^\\\[\$\@\/] |
6629             [\x00-\xFF] |
6630             \[\^ |
6631             \[\: (?>[a-z]+) \:\] |
6632             \[\:\^ (?>[a-z]+) \:\] |
6633             [\$\@\/] |
6634             \\ (?:$q_char) |
6635             (?:$q_char)
6636             ))/oxmsg;
6637              
6638             # unescape character
6639 13         55 for (my $i=0; $i <= $#char; $i++) {
6640 25 50 33     201 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6641             }
6642              
6643             # open character class [...]
6644 0         0 elsif ($char[$i] eq '[') {
6645 0         0 my $left = $i;
6646 0 0       0 if ($char[$i+1] eq ']') {
6647 0         0 $i++;
6648             }
6649 0         0 while (1) {
6650 0 0       0 if (++$i > $#char) {
6651 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6652             }
6653 0 0       0 if ($char[$i] eq ']') {
6654 0         0 my $right = $i;
6655              
6656             # [...]
6657 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
6658              
6659 0         0 $i = $left;
6660 0         0 last;
6661             }
6662             }
6663             }
6664              
6665             # open character class [^...]
6666             elsif ($char[$i] eq '[^') {
6667 0         0 my $left = $i;
6668 0 0       0 if ($char[$i+1] eq ']') {
6669 0         0 $i++;
6670             }
6671 0         0 while (1) {
6672 0 0       0 if (++$i > $#char) {
6673 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6674             }
6675 0 0       0 if ($char[$i] eq ']') {
6676 0         0 my $right = $i;
6677              
6678             # [^...]
6679 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6680              
6681 0         0 $i = $left;
6682 0         0 last;
6683             }
6684             }
6685             }
6686              
6687             # escape $ @ / and \
6688             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6689 0         0 $char[$i] = '\\' . $char[$i];
6690             }
6691              
6692             # rewrite character class or escape character
6693             elsif (my $char = character_class($char[$i],$modifier)) {
6694 6         19 $char[$i] = $char;
6695             }
6696              
6697             # /i modifier
6698             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
6699 0 0       0 if (CORE::length(Elatin5::fc($char[$i])) == 1) {
6700 0         0 $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
6701             }
6702             else {
6703 0         0 $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
6704             }
6705             }
6706              
6707             # quote character before ? + * {
6708             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6709 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6710             }
6711             else {
6712 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6713             }
6714             }
6715             }
6716              
6717 13         24 $modifier =~ tr/i//d;
6718 13         18 $delimiter = '/';
6719 13         20 $end_delimiter = '/';
6720 13         78 my $prematch = '';
6721 13         142 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6722             }
6723              
6724             #
6725             # escape regexp (s'here''b)
6726             #
6727             sub e_s1_qb {
6728 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6729              
6730             # split regexp
6731 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6732              
6733             # unescape character
6734 0         0 for (my $i=0; $i <= $#char; $i++) {
6735 0 0       0 if (0) {
    0          
6736             }
6737              
6738             # remain \\
6739 0         0 elsif ($char[$i] eq '\\\\') {
6740             }
6741              
6742             # escape $ @ / and \
6743             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6744 0         0 $char[$i] = '\\' . $char[$i];
6745             }
6746             }
6747              
6748 0         0 $delimiter = '/';
6749 0         0 $end_delimiter = '/';
6750 0         0 my $prematch = '';
6751 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6752             }
6753              
6754             #
6755             # escape regexp (s''here')
6756             #
6757             sub e_s2_q {
6758 16     16 0 28 my($ope,$delimiter,$end_delimiter,$string) = @_;
6759              
6760 16         23 $slash = 'div';
6761              
6762 16         151 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6763 16         61 for (my $i=0; $i <= $#char; $i++) {
6764 9 100       41 if (0) {
    100          
6765             }
6766              
6767             # not escape \\
6768 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6769             }
6770              
6771             # escape $ @ / and \
6772             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6773 5         17 $char[$i] = '\\' . $char[$i];
6774             }
6775             }
6776              
6777 16         55 return join '', $ope, $delimiter, @char, $end_delimiter;
6778             }
6779              
6780             #
6781             # escape regexp (s/here/and here/modifier)
6782             #
6783             sub e_sub {
6784 97     97 0 541 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6785 97   100     419 $modifier ||= '';
6786              
6787 97         201 $modifier =~ tr/p//d;
6788 97 50       314 if ($modifier =~ /([adlu])/oxms) {
6789 0         0 my $line = 0;
6790 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6791 0 0       0 if ($filename ne __FILE__) {
6792 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6793 0         0 last;
6794             }
6795             }
6796 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6797             }
6798              
6799 97 100       279 if ($variable eq '') {
6800 36         49 $variable = '$_';
6801 36         58 $bind_operator = ' =~ ';
6802             }
6803              
6804 97         161 $slash = 'div';
6805              
6806             # P.128 Start of match (or end of previous match): \G
6807             # P.130 Advanced Use of \G with Perl
6808             # in Chapter 3: Overview of Regular Expression Features and Flavors
6809             # P.312 Iterative Matching: Scalar Context, with /g
6810             # in Chapter 7: Perl
6811             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6812              
6813             # P.181 Where You Left Off: The \G Assertion
6814             # in Chapter 5: Pattern Matching
6815             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6816              
6817             # P.220 Where You Left Off: The \G Assertion
6818             # in Chapter 5: Pattern Matching
6819             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6820              
6821 97         145 my $e_modifier = $modifier =~ tr/e//d;
6822 97         135 my $r_modifier = $modifier =~ tr/r//d;
6823              
6824 97         130 my $my = '';
6825 97 50       278 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6826 0         0 $my = $variable;
6827 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6828 0         0 $variable =~ s/ = .+ \z//oxms;
6829             }
6830              
6831 97         248 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6832 97         181 $variable_basename =~ s/ \s+ \z//oxms;
6833              
6834             # quote replacement string
6835 97         119 my $e_replacement = '';
6836 97 100       242 if ($e_modifier >= 1) {
6837 17         429 $e_replacement = e_qq('', '', '', $replacement);
6838 17         34 $e_modifier--;
6839             }
6840             else {
6841 80 100       199 if ($delimiter2 eq "'") {
6842 16         40 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6843             }
6844             else {
6845 64         162 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6846             }
6847             }
6848              
6849 97         169 my $sub = '';
6850              
6851             # with /r
6852 97 100       252 if ($r_modifier) {
6853 8 100       17 if (0) {
6854             }
6855              
6856             # s///gr without multibyte anchoring
6857 0         0 elsif ($modifier =~ /g/oxms) {
6858 4 50       16 $sub = sprintf(
6859             # 1 2 3 4 5
6860             q,
6861              
6862             $variable, # 1
6863             ($delimiter1 eq "'") ? # 2
6864             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6865             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6866             $s_matched, # 3
6867             $e_replacement, # 4
6868             '$Latin5::re_r=CORE::eval $Latin5::re_r; ' x $e_modifier, # 5
6869             );
6870             }
6871              
6872             # s///r
6873             else {
6874              
6875 4         7 my $prematch = q{$`};
6876              
6877 4 50       27 $sub = sprintf(
6878             # 1 2 3 4 5 6 7
6879             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin5::re_r=%s; %s"%s$Latin5::re_r$'" } : %s>,
6880              
6881             $variable, # 1
6882             ($delimiter1 eq "'") ? # 2
6883             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6884             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6885             $s_matched, # 3
6886             $e_replacement, # 4
6887             '$Latin5::re_r=CORE::eval $Latin5::re_r; ' x $e_modifier, # 5
6888             $prematch, # 6
6889             $variable, # 7
6890             );
6891             }
6892              
6893             # $var !~ s///r doesn't make sense
6894 8 50       25 if ($bind_operator =~ / !~ /oxms) {
6895 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6896             }
6897             }
6898              
6899             # without /r
6900             else {
6901 89 100       238 if (0) {
6902             }
6903              
6904             # s///g without multibyte anchoring
6905 0         0 elsif ($modifier =~ /g/oxms) {
6906 22 100       135 $sub = sprintf(
    100          
6907             # 1 2 3 4 5 6 7 8
6908             q,
6909              
6910             $variable, # 1
6911             ($delimiter1 eq "'") ? # 2
6912             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6913             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6914             $s_matched, # 3
6915             $e_replacement, # 4
6916             '$Latin5::re_r=CORE::eval $Latin5::re_r; ' x $e_modifier, # 5
6917             $variable, # 6
6918             $variable, # 7
6919             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6920             );
6921             }
6922              
6923             # s///
6924             else {
6925              
6926 67         114 my $prematch = q{$`};
6927              
6928 67 100       462 $sub = sprintf(
    100          
6929              
6930             ($bind_operator =~ / =~ /oxms) ?
6931              
6932             # 1 2 3 4 5 6 7 8
6933             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin5::re_r=%s; %s%s="%s$Latin5::re_r$'"; 1 } : undef> :
6934              
6935             # 1 2 3 4 5 6 7 8
6936             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin5::re_r=%s; %s%s="%s$Latin5::re_r$'"; undef }>,
6937              
6938             $variable, # 1
6939             $bind_operator, # 2
6940             ($delimiter1 eq "'") ? # 3
6941             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6942             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6943             $s_matched, # 4
6944             $e_replacement, # 5
6945             '$Latin5::re_r=CORE::eval $Latin5::re_r; ' x $e_modifier, # 6
6946             $variable, # 7
6947             $prematch, # 8
6948             );
6949             }
6950             }
6951              
6952             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6953 97 50       299 if ($my ne '') {
6954 0         0 $sub = "($my, $sub)[1]";
6955             }
6956              
6957             # clear s/// variable
6958 97         146 $sub_variable = '';
6959 97         136 $bind_operator = '';
6960              
6961 97         839 return $sub;
6962             }
6963              
6964             #
6965             # escape regexp of split qr//
6966             #
6967             sub e_split {
6968 74     74 0 230 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6969 74   100     333 $modifier ||= '';
6970              
6971 74         94 $modifier =~ tr/p//d;
6972 74 50       340 if ($modifier =~ /([adlu])/oxms) {
6973 0         0 my $line = 0;
6974 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6975 0 0       0 if ($filename ne __FILE__) {
6976 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6977 0         0 last;
6978             }
6979             }
6980 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6981             }
6982              
6983 74         113 $slash = 'div';
6984              
6985             # /b /B modifier
6986 74 50       169 if ($modifier =~ tr/bB//d) {
6987 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6988             }
6989              
6990 74 50       177 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6991 74         345 my $metachar = qr/[\@\\|[\]{^]/oxms;
6992              
6993             # split regexp
6994 74         9485 my @char = $string =~ /\G((?>
6995             [^\\\$\@\[\(] |
6996             \\x (?>[0-9A-Fa-f]{1,2}) |
6997             \\ (?>[0-7]{2,3}) |
6998             \\c [\x40-\x5F] |
6999             \\x\{ (?>[0-9A-Fa-f]+) \} |
7000             \\o\{ (?>[0-7]+) \} |
7001             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7002             \\ $q_char |
7003             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7004             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7005             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7006             [\$\@] $qq_variable |
7007             \$ (?>\s* [0-9]+) |
7008             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7009             \$ \$ (?![\w\{]) |
7010             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7011             \[\^ |
7012             \[\: (?>[a-z]+) :\] |
7013             \[\:\^ (?>[a-z]+) :\] |
7014             \(\? |
7015             $q_char
7016             ))/oxmsg;
7017              
7018 74         267 my $left_e = 0;
7019 74         91 my $right_e = 0;
7020 74         320 for (my $i=0; $i <= $#char; $i++) {
7021              
7022             # "\L\u" --> "\u\L"
7023 249 50 33     1604 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7024 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7025             }
7026              
7027             # "\U\l" --> "\l\U"
7028             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7029 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7030             }
7031              
7032             # octal escape sequence
7033             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7034 1         2 $char[$i] = Elatin5::octchr($1);
7035             }
7036              
7037             # hexadecimal escape sequence
7038             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7039 1         3 $char[$i] = Elatin5::hexchr($1);
7040             }
7041              
7042             # \b{...} --> b\{...}
7043             # \B{...} --> B\{...}
7044             # \N{CHARNAME} --> N\{CHARNAME}
7045             # \p{PROPERTY} --> p\{PROPERTY}
7046             # \P{PROPERTY} --> P\{PROPERTY}
7047             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7048 0         0 $char[$i] = $1 . '\\' . $2;
7049             }
7050              
7051             # \p, \P, \X --> p, P, X
7052             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7053 0         0 $char[$i] = $1;
7054             }
7055              
7056 249 50 100     853 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          
7057             }
7058              
7059             # join separated multiple-octet
7060 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7061 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        
7062 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
7063             }
7064             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)) {
7065 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
7066             }
7067             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)) {
7068 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
7069             }
7070             }
7071              
7072             # open character class [...]
7073             elsif ($char[$i] eq '[') {
7074 3         5 my $left = $i;
7075 3 50       12 if ($char[$i+1] eq ']') {
7076 0         0 $i++;
7077             }
7078 3         4 while (1) {
7079 7 50       27 if (++$i > $#char) {
7080 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7081             }
7082 7 100       20 if ($char[$i] eq ']') {
7083 3         4 my $right = $i;
7084              
7085             # [...]
7086 3 50       23 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7087 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7088             }
7089             else {
7090 3         18 splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
7091             }
7092              
7093 3         7 $i = $left;
7094 3         11 last;
7095             }
7096             }
7097             }
7098              
7099             # open character class [^...]
7100             elsif ($char[$i] eq '[^') {
7101 0         0 my $left = $i;
7102 0 0       0 if ($char[$i+1] eq ']') {
7103 0         0 $i++;
7104             }
7105 0         0 while (1) {
7106 0 0       0 if (++$i > $#char) {
7107 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7108             }
7109 0 0       0 if ($char[$i] eq ']') {
7110 0         0 my $right = $i;
7111              
7112             # [^...]
7113 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7114 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin5::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7115             }
7116             else {
7117 0         0 splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7118             }
7119              
7120 0         0 $i = $left;
7121 0         0 last;
7122             }
7123             }
7124             }
7125              
7126             # rewrite character class or escape character
7127             elsif (my $char = character_class($char[$i],$modifier)) {
7128 1         3 $char[$i] = $char;
7129             }
7130              
7131             # P.794 29.2.161. split
7132             # in Chapter 29: Functions
7133             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7134              
7135             # P.951 split
7136             # in Chapter 27: Functions
7137             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7138              
7139             # said "The //m modifier is assumed when you split on the pattern /^/",
7140             # but perl5.008 is not so. Therefore, this software adds //m.
7141             # (and so on)
7142              
7143             # split(m/^/) --> split(m/^/m)
7144             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7145 7         32 $modifier .= 'm';
7146             }
7147              
7148             # /i modifier
7149             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
7150 0 0       0 if (CORE::length(Elatin5::fc($char[$i])) == 1) {
7151 0         0 $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
7152             }
7153             else {
7154 0         0 $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
7155             }
7156             }
7157              
7158             # \u \l \U \L \F \Q \E
7159             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7160 0 0       0 if ($right_e < $left_e) {
7161 0         0 $char[$i] = '\\' . $char[$i];
7162             }
7163             }
7164             elsif ($char[$i] eq '\u') {
7165 0         0 $char[$i] = '@{[Elatin5::ucfirst qq<';
7166 0         0 $left_e++;
7167             }
7168             elsif ($char[$i] eq '\l') {
7169 0         0 $char[$i] = '@{[Elatin5::lcfirst qq<';
7170 0         0 $left_e++;
7171             }
7172             elsif ($char[$i] eq '\U') {
7173 0         0 $char[$i] = '@{[Elatin5::uc qq<';
7174 0         0 $left_e++;
7175             }
7176             elsif ($char[$i] eq '\L') {
7177 0         0 $char[$i] = '@{[Elatin5::lc qq<';
7178 0         0 $left_e++;
7179             }
7180             elsif ($char[$i] eq '\F') {
7181 0         0 $char[$i] = '@{[Elatin5::fc qq<';
7182 0         0 $left_e++;
7183             }
7184             elsif ($char[$i] eq '\Q') {
7185 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7186 0         0 $left_e++;
7187             }
7188             elsif ($char[$i] eq '\E') {
7189 0 0       0 if ($right_e < $left_e) {
7190 0         0 $char[$i] = '>]}';
7191 0         0 $right_e++;
7192             }
7193             else {
7194 0         0 $char[$i] = '';
7195             }
7196             }
7197             elsif ($char[$i] eq '\Q') {
7198 0         0 while (1) {
7199 0 0       0 if (++$i > $#char) {
7200 0         0 last;
7201             }
7202 0 0       0 if ($char[$i] eq '\E') {
7203 0         0 last;
7204             }
7205             }
7206             }
7207             elsif ($char[$i] eq '\E') {
7208             }
7209              
7210             # $0 --> $0
7211             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7212 0 0       0 if ($ignorecase) {
7213 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7214             }
7215             }
7216             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7217 0 0       0 if ($ignorecase) {
7218 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7219             }
7220             }
7221              
7222             # $$ --> $$
7223             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7224             }
7225              
7226             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7227             # $1, $2, $3 --> $1, $2, $3 otherwise
7228             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7229 0         0 $char[$i] = e_capture($1);
7230 0 0       0 if ($ignorecase) {
7231 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7232             }
7233             }
7234             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7235 0         0 $char[$i] = e_capture($1);
7236 0 0       0 if ($ignorecase) {
7237 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7238             }
7239             }
7240              
7241             # $$foo[ ... ] --> $ $foo->[ ... ]
7242             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7243 0         0 $char[$i] = e_capture($1.'->'.$2);
7244 0 0       0 if ($ignorecase) {
7245 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7246             }
7247             }
7248              
7249             # $$foo{ ... } --> $ $foo->{ ... }
7250             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7251 0         0 $char[$i] = e_capture($1.'->'.$2);
7252 0 0       0 if ($ignorecase) {
7253 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7254             }
7255             }
7256              
7257             # $$foo
7258             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7259 0         0 $char[$i] = e_capture($1);
7260 0 0       0 if ($ignorecase) {
7261 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7262             }
7263             }
7264              
7265             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin5::PREMATCH()
7266             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7267 12 50       22 if ($ignorecase) {
7268 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::PREMATCH())]}';
7269             }
7270             else {
7271 12         86 $char[$i] = '@{[Elatin5::PREMATCH()]}';
7272             }
7273             }
7274              
7275             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin5::MATCH()
7276             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7277 12 50       25 if ($ignorecase) {
7278 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::MATCH())]}';
7279             }
7280             else {
7281 12         86 $char[$i] = '@{[Elatin5::MATCH()]}';
7282             }
7283             }
7284              
7285             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin5::POSTMATCH()
7286             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7287 9 50       17 if ($ignorecase) {
7288 0         0 $char[$i] = '@{[Elatin5::ignorecase(Elatin5::POSTMATCH())]}';
7289             }
7290             else {
7291 9         61 $char[$i] = '@{[Elatin5::POSTMATCH()]}';
7292             }
7293             }
7294              
7295             # ${ foo }
7296             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7297 0 0       0 if ($ignorecase) {
7298 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $1 . ')]}';
7299             }
7300             }
7301              
7302             # ${ ... }
7303             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7304 0         0 $char[$i] = e_capture($1);
7305 0 0       0 if ($ignorecase) {
7306 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7307             }
7308             }
7309              
7310             # $scalar or @array
7311             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7312 3         6 $char[$i] = e_string($char[$i]);
7313 3 50       19 if ($ignorecase) {
7314 0         0 $char[$i] = '@{[Elatin5::ignorecase(' . $char[$i] . ')]}';
7315             }
7316             }
7317              
7318             # quote character before ? + * {
7319             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7320 1 50       11 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7321             }
7322             else {
7323 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7324             }
7325             }
7326             }
7327              
7328             # make regexp string
7329 74         107 $modifier =~ tr/i//d;
7330 74 50       181 if ($left_e > $right_e) {
7331 0         0 return join '', 'Elatin5::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7332             }
7333 74         743 return join '', 'Elatin5::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7334             }
7335              
7336             #
7337             # escape regexp of split qr''
7338             #
7339             sub e_split_q {
7340 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7341 0   0       $modifier ||= '';
7342              
7343 0           $modifier =~ tr/p//d;
7344 0 0         if ($modifier =~ /([adlu])/oxms) {
7345 0           my $line = 0;
7346 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7347 0 0         if ($filename ne __FILE__) {
7348 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7349 0           last;
7350             }
7351             }
7352 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7353             }
7354              
7355 0           $slash = 'div';
7356              
7357             # /b /B modifier
7358 0 0         if ($modifier =~ tr/bB//d) {
7359 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7360             }
7361              
7362 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7363              
7364             # split regexp
7365 0           my @char = $string =~ /\G((?>
7366             [^\\\[] |
7367             [\x00-\xFF] |
7368             \[\^ |
7369             \[\: (?>[a-z]+) \:\] |
7370             \[\:\^ (?>[a-z]+) \:\] |
7371             \\ (?:$q_char) |
7372             (?:$q_char)
7373             ))/oxmsg;
7374              
7375             # unescape character
7376 0           for (my $i=0; $i <= $#char; $i++) {
7377 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7378             }
7379              
7380             # open character class [...]
7381 0           elsif ($char[$i] eq '[') {
7382 0           my $left = $i;
7383 0 0         if ($char[$i+1] eq ']') {
7384 0           $i++;
7385             }
7386 0           while (1) {
7387 0 0         if (++$i > $#char) {
7388 0           die __FILE__, ": Unmatched [] in regexp\n";
7389             }
7390 0 0         if ($char[$i] eq ']') {
7391 0           my $right = $i;
7392              
7393             # [...]
7394 0           splice @char, $left, $right-$left+1, Elatin5::charlist_qr(@char[$left+1..$right-1], $modifier);
7395              
7396 0           $i = $left;
7397 0           last;
7398             }
7399             }
7400             }
7401              
7402             # open character class [^...]
7403             elsif ($char[$i] eq '[^') {
7404 0           my $left = $i;
7405 0 0         if ($char[$i+1] eq ']') {
7406 0           $i++;
7407             }
7408 0           while (1) {
7409 0 0         if (++$i > $#char) {
7410 0           die __FILE__, ": Unmatched [] in regexp\n";
7411             }
7412 0 0         if ($char[$i] eq ']') {
7413 0           my $right = $i;
7414              
7415             # [^...]
7416 0           splice @char, $left, $right-$left+1, Elatin5::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7417              
7418 0           $i = $left;
7419 0           last;
7420             }
7421             }
7422             }
7423              
7424             # rewrite character class or escape character
7425             elsif (my $char = character_class($char[$i],$modifier)) {
7426 0           $char[$i] = $char;
7427             }
7428              
7429             # split(m/^/) --> split(m/^/m)
7430             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7431 0           $modifier .= 'm';
7432             }
7433              
7434             # /i modifier
7435             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin5::uc($char[$i]) ne Elatin5::fc($char[$i]))) {
7436 0 0         if (CORE::length(Elatin5::fc($char[$i])) == 1) {
7437 0           $char[$i] = '[' . Elatin5::uc($char[$i]) . Elatin5::fc($char[$i]) . ']';
7438             }
7439             else {
7440 0           $char[$i] = '(?:' . Elatin5::uc($char[$i]) . '|' . Elatin5::fc($char[$i]) . ')';
7441             }
7442             }
7443              
7444             # quote character before ? + * {
7445             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7446 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7447             }
7448             else {
7449 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7450             }
7451             }
7452             }
7453              
7454 0           $modifier =~ tr/i//d;
7455 0           return join '', 'Elatin5::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7456             }
7457              
7458             #
7459             # instead of Carp::carp
7460             #
7461             sub carp {
7462 0     0 0   my($package,$filename,$line) = caller(1);
7463 0           print STDERR "@_ at $filename line $line.\n";
7464             }
7465              
7466             #
7467             # instead of Carp::croak
7468             #
7469             sub croak {
7470 0     0 0   my($package,$filename,$line) = caller(1);
7471 0           print STDERR "@_ at $filename line $line.\n";
7472 0           die "\n";
7473             }
7474              
7475             #
7476             # instead of Carp::cluck
7477             #
7478             sub cluck {
7479 0     0 0   my $i = 0;
7480 0           my @cluck = ();
7481 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7482 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7483 0           $i++;
7484             }
7485 0           print STDERR CORE::reverse @cluck;
7486 0           print STDERR "\n";
7487 0           carp @_;
7488             }
7489              
7490             #
7491             # instead of Carp::confess
7492             #
7493             sub confess {
7494 0     0 0   my $i = 0;
7495 0           my @confess = ();
7496 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7497 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7498 0           $i++;
7499             }
7500 0           print STDERR CORE::reverse @confess;
7501 0           print STDERR "\n";
7502 0           croak @_;
7503             }
7504              
7505             1;
7506              
7507             __END__