File Coverage

blib/lib/Elatin10.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 Elatin10;
2             ######################################################################
3             #
4             # Elatin10 - Run-time routines for Latin10.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin10/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   2665 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         421  
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   9951 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   759  
  200         233  
  200         21901  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   931 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         214 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         18799 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   9745 CORE::eval q{
  200     200   746  
  200     75   228  
  200         16596  
  62         4432  
  48         3316  
  59         4165  
  31         2158  
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       75021 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   425 my $genpkg = "Symbol::";
67 200         7006 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) && (Elatin10::index($name, '::') == -1) && (Elatin10::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   290 if (CORE::eval { local $@; CORE::require strict }) {
  200         287  
  200         1566  
115 200         16055 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   10673 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   745  
  200         219  
  200         8861  
145 200     200   9283 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   746  
  200         221  
  200         9385  
146 200     200   8711 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   695  
  200         219  
  200         10206  
147              
148             #
149             # Latin-10 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   9170 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   667  
  200         228  
  200         262067  
157              
158             #
159             # Latin-10 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 Elatin10 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-16 | iec[- ]?8859-16 | latin-?10 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA1" => "\xA2", # LATIN LETTER A WITH OGONEK
183             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
184             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
185             "\xAA" => "\xBA", # LATIN LETTER S WITH COMMA BELOW
186             "\xAC" => "\xAE", # LATIN LETTER Z WITH ACUTE
187             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
188             "\xB2" => "\xB9", # LATIN LETTER C WITH CARON
189             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
190             "\xBC" => "\xBD", # LATIN LIGATURE OE
191             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
192             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
193             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
194             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
195             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
196             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
197             "\xC5" => "\xE5", # LATIN LETTER C WITH ACUTE
198             "\xC6" => "\xE6", # LATIN LETTER AE
199             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
200             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
201             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
202             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
203             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
204             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
205             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
206             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
207             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
208             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
209             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
210             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
211             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
212             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
213             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
214             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
215             "\xD7" => "\xF7", # LATIN LETTER S WITH ACUTE
216             "\xD8" => "\xF8", # LATIN LETTER U WITH DOUBLE ACUTE
217             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
218             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
219             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
220             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
221             "\xDD" => "\xFD", # LATIN LETTER E WITH OGONEK
222             "\xDE" => "\xFE", # LATIN LETTER T WITH COMMA BELOW
223             );
224              
225             %uc = (%uc,
226             "\xA2" => "\xA1", # LATIN LETTER A WITH OGONEK
227             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
228             "\xAE" => "\xAC", # LATIN LETTER Z WITH ACUTE
229             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
230             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
231             "\xB9" => "\xB2", # LATIN LETTER C WITH CARON
232             "\xBA" => "\xAA", # LATIN LETTER S WITH COMMA BELOW
233             "\xBD" => "\xBC", # LATIN LIGATURE OE
234             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
235             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
236             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
237             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
238             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
239             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
240             "\xE5" => "\xC5", # LATIN LETTER C WITH ACUTE
241             "\xE6" => "\xC6", # LATIN LETTER AE
242             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
243             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
244             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
245             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
246             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
247             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
248             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
249             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
250             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
251             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
252             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
253             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
254             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
255             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
256             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
257             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
258             "\xF7" => "\xD7", # LATIN LETTER S WITH ACUTE
259             "\xF8" => "\xD8", # LATIN LETTER U WITH DOUBLE ACUTE
260             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
261             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
262             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
263             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
264             "\xFD" => "\xDD", # LATIN LETTER E WITH OGONEK
265             "\xFE" => "\xDE", # LATIN LETTER T WITH COMMA BELOW
266             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
267             );
268              
269             %fc = (%fc,
270             "\xA1" => "\xA2", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
271             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
272             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
273             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH COMMA BELOW --> LATIN SMALL LETTER S WITH COMMA BELOW
274             "\xAC" => "\xAE", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
275             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
276             "\xB2" => "\xB9", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
277             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
278             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
279             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
280             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
281             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
282             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
283             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
284             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
285             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
286             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
287             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
288             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
289             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
290             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
291             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
292             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
293             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
294             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
295             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
296             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
297             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
298             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
299             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
300             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
301             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
302             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
303             "\xD7" => "\xF7", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
304             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
305             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
306             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
307             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
308             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
309             "\xDD" => "\xFD", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
310             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH COMMA BELOW --> LATIN SMALL LETTER T WITH COMMA BELOW
311             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
312             );
313             }
314              
315             else {
316             croak "Don't know my package name '@{[__PACKAGE__]}'";
317             }
318              
319             #
320             # @ARGV wildcard globbing
321             #
322             sub import {
323              
324 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
325 0         0 my @argv = ();
326 0         0 for (@ARGV) {
327              
328             # has space
329 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
330 0 0       0 if (my @glob = Elatin10::glob(qq{"$_"})) {
331 0         0 push @argv, @glob;
332             }
333             else {
334 0         0 push @argv, $_;
335             }
336             }
337              
338             # has wildcard metachar
339             elsif (/\A (?:$q_char)*? [*?] /oxms) {
340 0 0       0 if (my @glob = Elatin10::glob($_)) {
341 0         0 push @argv, @glob;
342             }
343             else {
344 0         0 push @argv, $_;
345             }
346             }
347              
348             # no wildcard globbing
349             else {
350 0         0 push @argv, $_;
351             }
352             }
353 0         0 @ARGV = @argv;
354             }
355              
356 0         0 *Char::ord = \&Latin10::ord;
357 0         0 *Char::ord_ = \&Latin10::ord_;
358 0         0 *Char::reverse = \&Latin10::reverse;
359 0         0 *Char::getc = \&Latin10::getc;
360 0         0 *Char::length = \&Latin10::length;
361 0         0 *Char::substr = \&Latin10::substr;
362 0         0 *Char::index = \&Latin10::index;
363 0         0 *Char::rindex = \&Latin10::rindex;
364 0         0 *Char::eval = \&Latin10::eval;
365 0         0 *Char::escape = \&Latin10::escape;
366 0         0 *Char::escape_token = \&Latin10::escape_token;
367 0         0 *Char::escape_script = \&Latin10::escape_script;
368             }
369              
370             # P.230 Care with Prototypes
371             # in Chapter 6: Subroutines
372             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
373             #
374             # If you aren't careful, you can get yourself into trouble with prototypes.
375             # But if you are careful, you can do a lot of neat things with them. This is
376             # all very powerful, of course, and should only be used in moderation to make
377             # the world a better place.
378              
379             # P.332 Care with Prototypes
380             # in Chapter 7: Subroutines
381             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
382             #
383             # If you aren't careful, you can get yourself into trouble with prototypes.
384             # But if you are careful, you can do a lot of neat things with them. This is
385             # all very powerful, of course, and should only be used in moderation to make
386             # the world a better place.
387              
388             #
389             # Prototypes of subroutines
390             #
391       0     sub unimport {}
392             sub Elatin10::split(;$$$);
393             sub Elatin10::tr($$$$;$);
394             sub Elatin10::chop(@);
395             sub Elatin10::index($$;$);
396             sub Elatin10::rindex($$;$);
397             sub Elatin10::lcfirst(@);
398             sub Elatin10::lcfirst_();
399             sub Elatin10::lc(@);
400             sub Elatin10::lc_();
401             sub Elatin10::ucfirst(@);
402             sub Elatin10::ucfirst_();
403             sub Elatin10::uc(@);
404             sub Elatin10::uc_();
405             sub Elatin10::fc(@);
406             sub Elatin10::fc_();
407             sub Elatin10::ignorecase;
408             sub Elatin10::classic_character_class;
409             sub Elatin10::capture;
410             sub Elatin10::chr(;$);
411             sub Elatin10::chr_();
412             sub Elatin10::glob($);
413             sub Elatin10::glob_();
414              
415             sub Latin10::ord(;$);
416             sub Latin10::ord_();
417             sub Latin10::reverse(@);
418             sub Latin10::getc(;*@);
419             sub Latin10::length(;$);
420             sub Latin10::substr($$;$$);
421             sub Latin10::index($$;$);
422             sub Latin10::rindex($$;$);
423             sub Latin10::escape(;$);
424              
425             #
426             # Regexp work
427             #
428 200     200   11546 BEGIN { CORE::eval q{ use vars qw(
  200     200   889  
  200         252  
  200         56507  
429             $Latin10::re_a
430             $Latin10::re_t
431             $Latin10::re_n
432             $Latin10::re_r
433             ) } }
434              
435             #
436             # Character class
437             #
438 200     200   11796 BEGIN { CORE::eval q{ use vars qw(
  200     200   807  
  200         223  
  200         1861509  
439             $dot
440             $dot_s
441             $eD
442             $eS
443             $eW
444             $eH
445             $eV
446             $eR
447             $eN
448             $not_alnum
449             $not_alpha
450             $not_ascii
451             $not_blank
452             $not_cntrl
453             $not_digit
454             $not_graph
455             $not_lower
456             $not_lower_i
457             $not_print
458             $not_punct
459             $not_space
460             $not_upper
461             $not_upper_i
462             $not_word
463             $not_xdigit
464             $eb
465             $eB
466             ) } }
467              
468             ${Elatin10::dot} = qr{(?>[^\x0A])};
469             ${Elatin10::dot_s} = qr{(?>[\x00-\xFF])};
470             ${Elatin10::eD} = qr{(?>[^0-9])};
471              
472             # Vertical tabs are now whitespace
473             # \s in a regex now matches a vertical tab in all circumstances.
474             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
475             # ${Elatin10::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
476             # ${Elatin10::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
477             ${Elatin10::eS} = qr{(?>[^\s])};
478              
479             ${Elatin10::eW} = qr{(?>[^0-9A-Z_a-z])};
480             ${Elatin10::eH} = qr{(?>[^\x09\x20])};
481             ${Elatin10::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
482             ${Elatin10::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
483             ${Elatin10::eN} = qr{(?>[^\x0A])};
484             ${Elatin10::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
485             ${Elatin10::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
486             ${Elatin10::not_ascii} = qr{(?>[^\x00-\x7F])};
487             ${Elatin10::not_blank} = qr{(?>[^\x09\x20])};
488             ${Elatin10::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
489             ${Elatin10::not_digit} = qr{(?>[^\x30-\x39])};
490             ${Elatin10::not_graph} = qr{(?>[^\x21-\x7F])};
491             ${Elatin10::not_lower} = qr{(?>[^\x61-\x7A])};
492             ${Elatin10::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
493             # ${Elatin10::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
494             ${Elatin10::not_print} = qr{(?>[^\x20-\x7F])};
495             ${Elatin10::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
496             ${Elatin10::not_space} = qr{(?>[^\s\x0B])};
497             ${Elatin10::not_upper} = qr{(?>[^\x41-\x5A])};
498             ${Elatin10::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
499             # ${Elatin10::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
500             ${Elatin10::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
501             ${Elatin10::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
502             ${Elatin10::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))};
503             ${Elatin10::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]))};
504              
505             # avoid: Name "Elatin10::foo" used only once: possible typo at here.
506             ${Elatin10::dot} = ${Elatin10::dot};
507             ${Elatin10::dot_s} = ${Elatin10::dot_s};
508             ${Elatin10::eD} = ${Elatin10::eD};
509             ${Elatin10::eS} = ${Elatin10::eS};
510             ${Elatin10::eW} = ${Elatin10::eW};
511             ${Elatin10::eH} = ${Elatin10::eH};
512             ${Elatin10::eV} = ${Elatin10::eV};
513             ${Elatin10::eR} = ${Elatin10::eR};
514             ${Elatin10::eN} = ${Elatin10::eN};
515             ${Elatin10::not_alnum} = ${Elatin10::not_alnum};
516             ${Elatin10::not_alpha} = ${Elatin10::not_alpha};
517             ${Elatin10::not_ascii} = ${Elatin10::not_ascii};
518             ${Elatin10::not_blank} = ${Elatin10::not_blank};
519             ${Elatin10::not_cntrl} = ${Elatin10::not_cntrl};
520             ${Elatin10::not_digit} = ${Elatin10::not_digit};
521             ${Elatin10::not_graph} = ${Elatin10::not_graph};
522             ${Elatin10::not_lower} = ${Elatin10::not_lower};
523             ${Elatin10::not_lower_i} = ${Elatin10::not_lower_i};
524             ${Elatin10::not_print} = ${Elatin10::not_print};
525             ${Elatin10::not_punct} = ${Elatin10::not_punct};
526             ${Elatin10::not_space} = ${Elatin10::not_space};
527             ${Elatin10::not_upper} = ${Elatin10::not_upper};
528             ${Elatin10::not_upper_i} = ${Elatin10::not_upper_i};
529             ${Elatin10::not_word} = ${Elatin10::not_word};
530             ${Elatin10::not_xdigit} = ${Elatin10::not_xdigit};
531             ${Elatin10::eb} = ${Elatin10::eb};
532             ${Elatin10::eB} = ${Elatin10::eB};
533              
534             #
535             # Latin-10 split
536             #
537             sub Elatin10::split(;$$$) {
538              
539             # P.794 29.2.161. split
540             # in Chapter 29: Functions
541             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
542              
543             # P.951 split
544             # in Chapter 27: Functions
545             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
546              
547 0     0 0 0 my $pattern = $_[0];
548 0         0 my $string = $_[1];
549 0         0 my $limit = $_[2];
550              
551             # if $pattern is also omitted or is the literal space, " "
552 0 0       0 if (not defined $pattern) {
553 0         0 $pattern = ' ';
554             }
555              
556             # if $string is omitted, the function splits the $_ string
557 0 0       0 if (not defined $string) {
558 0 0       0 if (defined $_) {
559 0         0 $string = $_;
560             }
561             else {
562 0         0 $string = '';
563             }
564             }
565              
566 0         0 my @split = ();
567              
568             # when string is empty
569 0 0       0 if ($string eq '') {
    0          
570              
571             # resulting list value in list context
572 0 0       0 if (wantarray) {
573 0         0 return @split;
574             }
575              
576             # count of substrings in scalar context
577             else {
578 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
579 0         0 @_ = @split;
580 0         0 return scalar @_;
581             }
582             }
583              
584             # split's first argument is more consistently interpreted
585             #
586             # After some changes earlier in v5.17, split's behavior has been simplified:
587             # if the PATTERN argument evaluates to a string containing one space, it is
588             # treated the way that a literal string containing one space once was.
589             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
590              
591             # if $pattern is also omitted or is the literal space, " ", the function splits
592             # on whitespace, /\s+/, after skipping any leading whitespace
593             # (and so on)
594              
595             elsif ($pattern eq ' ') {
596 0 0       0 if (not defined $limit) {
597 0         0 return CORE::split(' ', $string);
598             }
599             else {
600 0         0 return CORE::split(' ', $string, $limit);
601             }
602             }
603              
604             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
605 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
606              
607             # a pattern capable of matching either the null string or something longer than the
608             # null string will split the value of $string into separate characters wherever it
609             # matches the null string between characters
610             # (and so on)
611              
612 0 0       0 if ('' =~ / \A $pattern \z /xms) {
613 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
614 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
615              
616             # P.1024 Appendix W.10 Multibyte Processing
617             # of ISBN 1-56592-224-7 CJKV Information Processing
618             # (and so on)
619              
620             # the //m modifier is assumed when you split on the pattern /^/
621             # (and so on)
622              
623             # V
624 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
625              
626             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
627             # is included in the resulting list, interspersed with the fields that are ordinarily returned
628             # (and so on)
629              
630 0         0 local $@;
631 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
632 0         0 push @split, CORE::eval('$' . $digit);
633             }
634             }
635             }
636              
637             else {
638 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
639              
640             # V
641 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
642 0         0 local $@;
643 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
644 0         0 push @split, CORE::eval('$' . $digit);
645             }
646             }
647             }
648             }
649              
650             elsif ($limit > 0) {
651 0 0       0 if ('' =~ / \A $pattern \z /xms) {
652 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
653 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
654              
655             # V
656 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
657 0         0 local $@;
658 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
659 0         0 push @split, CORE::eval('$' . $digit);
660             }
661             }
662             }
663             }
664             else {
665 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
666 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
667              
668             # V
669 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
670 0         0 local $@;
671 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
672 0         0 push @split, CORE::eval('$' . $digit);
673             }
674             }
675             }
676             }
677             }
678              
679 0 0       0 if (CORE::length($string) > 0) {
680 0         0 push @split, $string;
681             }
682              
683             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
684 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
685 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
686 0         0 pop @split;
687             }
688             }
689              
690             # resulting list value in list context
691 0 0       0 if (wantarray) {
692 0         0 return @split;
693             }
694              
695             # count of substrings in scalar context
696             else {
697 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
698 0         0 @_ = @split;
699 0         0 return scalar @_;
700             }
701             }
702              
703             #
704             # get last subexpression offsets
705             #
706             sub _last_subexpression_offsets {
707 0     0   0 my $pattern = $_[0];
708              
709             # remove comment
710 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
711              
712 0         0 my $modifier = '';
713 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
714 0         0 $modifier = $1;
715 0         0 $modifier =~ s/-[A-Za-z]*//;
716             }
717              
718             # with /x modifier
719 0         0 my @char = ();
720 0 0       0 if ($modifier =~ /x/oxms) {
721 0         0 @char = $pattern =~ /\G((?>
722             [^\\\#\[\(] |
723             \\ $q_char |
724             \# (?>[^\n]*) $ |
725             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
726             \(\? |
727             $q_char
728             ))/oxmsg;
729             }
730              
731             # without /x modifier
732             else {
733 0         0 @char = $pattern =~ /\G((?>
734             [^\\\[\(] |
735             \\ $q_char |
736             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
737             \(\? |
738             $q_char
739             ))/oxmsg;
740             }
741              
742 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
743             }
744              
745             #
746             # Latin-10 transliteration (tr///)
747             #
748             sub Elatin10::tr($$$$;$) {
749              
750 0     0 0 0 my $bind_operator = $_[1];
751 0         0 my $searchlist = $_[2];
752 0         0 my $replacementlist = $_[3];
753 0   0     0 my $modifier = $_[4] || '';
754              
755 0 0       0 if ($modifier =~ /r/oxms) {
756 0 0       0 if ($bind_operator =~ / !~ /oxms) {
757 0         0 croak "Using !~ with tr///r doesn't make sense";
758             }
759             }
760              
761 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
762 0         0 my @searchlist = _charlist_tr($searchlist);
763 0         0 my @replacementlist = _charlist_tr($replacementlist);
764              
765 0         0 my %tr = ();
766 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
767 0 0       0 if (not exists $tr{$searchlist[$i]}) {
768 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
769 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
770             }
771             elsif ($modifier =~ /d/oxms) {
772 0         0 $tr{$searchlist[$i]} = '';
773             }
774             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
775 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
776             }
777             else {
778 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
779             }
780             }
781             }
782              
783 0         0 my $tr = 0;
784 0         0 my $replaced = '';
785 0 0       0 if ($modifier =~ /c/oxms) {
786 0         0 while (defined(my $char = shift @char)) {
787 0 0       0 if (not exists $tr{$char}) {
788 0 0       0 if (defined $replacementlist[0]) {
789 0         0 $replaced .= $replacementlist[0];
790             }
791 0         0 $tr++;
792 0 0       0 if ($modifier =~ /s/oxms) {
793 0   0     0 while (@char and (not exists $tr{$char[0]})) {
794 0         0 shift @char;
795 0         0 $tr++;
796             }
797             }
798             }
799             else {
800 0         0 $replaced .= $char;
801             }
802             }
803             }
804             else {
805 0         0 while (defined(my $char = shift @char)) {
806 0 0       0 if (exists $tr{$char}) {
807 0         0 $replaced .= $tr{$char};
808 0         0 $tr++;
809 0 0       0 if ($modifier =~ /s/oxms) {
810 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
811 0         0 shift @char;
812 0         0 $tr++;
813             }
814             }
815             }
816             else {
817 0         0 $replaced .= $char;
818             }
819             }
820             }
821              
822 0 0       0 if ($modifier =~ /r/oxms) {
823 0         0 return $replaced;
824             }
825             else {
826 0         0 $_[0] = $replaced;
827 0 0       0 if ($bind_operator =~ / !~ /oxms) {
828 0         0 return not $tr;
829             }
830             else {
831 0         0 return $tr;
832             }
833             }
834             }
835              
836             #
837             # Latin-10 chop
838             #
839             sub Elatin10::chop(@) {
840              
841 0     0 0 0 my $chop;
842 0 0       0 if (@_ == 0) {
843 0         0 my @char = /\G (?>$q_char) /oxmsg;
844 0         0 $chop = pop @char;
845 0         0 $_ = join '', @char;
846             }
847             else {
848 0         0 for (@_) {
849 0         0 my @char = /\G (?>$q_char) /oxmsg;
850 0         0 $chop = pop @char;
851 0         0 $_ = join '', @char;
852             }
853             }
854 0         0 return $chop;
855             }
856              
857             #
858             # Latin-10 index by octet
859             #
860             sub Elatin10::index($$;$) {
861              
862 0     0 1 0 my($str,$substr,$position) = @_;
863 0   0     0 $position ||= 0;
864 0         0 my $pos = 0;
865              
866 0         0 while ($pos < CORE::length($str)) {
867 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
868 0 0       0 if ($pos >= $position) {
869 0         0 return $pos;
870             }
871             }
872 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
873 0         0 $pos += CORE::length($1);
874             }
875             else {
876 0         0 $pos += 1;
877             }
878             }
879 0         0 return -1;
880             }
881              
882             #
883             # Latin-10 reverse index
884             #
885             sub Elatin10::rindex($$;$) {
886              
887 0     0 0 0 my($str,$substr,$position) = @_;
888 0   0     0 $position ||= CORE::length($str) - 1;
889 0         0 my $pos = 0;
890 0         0 my $rindex = -1;
891              
892 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
893 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
894 0         0 $rindex = $pos;
895             }
896 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
897 0         0 $pos += CORE::length($1);
898             }
899             else {
900 0         0 $pos += 1;
901             }
902             }
903 0         0 return $rindex;
904             }
905              
906             #
907             # Latin-10 lower case first with parameter
908             #
909             sub Elatin10::lcfirst(@) {
910 0 0   0 0 0 if (@_) {
911 0         0 my $s = shift @_;
912 0 0 0     0 if (@_ and wantarray) {
913 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
914             }
915             else {
916 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
917             }
918             }
919             else {
920 0         0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
921             }
922             }
923              
924             #
925             # Latin-10 lower case first without parameter
926             #
927             sub Elatin10::lcfirst_() {
928 0     0 0 0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
929             }
930              
931             #
932             # Latin-10 lower case with parameter
933             #
934             sub Elatin10::lc(@) {
935 0 0   0 0 0 if (@_) {
936 0         0 my $s = shift @_;
937 0 0 0     0 if (@_ and wantarray) {
938 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
939             }
940             else {
941 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
942             }
943             }
944             else {
945 0         0 return Elatin10::lc_();
946             }
947             }
948              
949             #
950             # Latin-10 lower case without parameter
951             #
952             sub Elatin10::lc_() {
953 0     0 0 0 my $s = $_;
954 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
955             }
956              
957             #
958             # Latin-10 upper case first with parameter
959             #
960             sub Elatin10::ucfirst(@) {
961 0 0   0 0 0 if (@_) {
962 0         0 my $s = shift @_;
963 0 0 0     0 if (@_ and wantarray) {
964 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
965             }
966             else {
967 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
968             }
969             }
970             else {
971 0         0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
972             }
973             }
974              
975             #
976             # Latin-10 upper case first without parameter
977             #
978             sub Elatin10::ucfirst_() {
979 0     0 0 0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
980             }
981              
982             #
983             # Latin-10 upper case with parameter
984             #
985             sub Elatin10::uc(@) {
986 174 50   174 0 196 if (@_) {
987 174         156 my $s = shift @_;
988 174 50 33     300 if (@_ and wantarray) {
989 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
990             }
991             else {
992 174 100       439 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         473  
993             }
994             }
995             else {
996 0         0 return Elatin10::uc_();
997             }
998             }
999              
1000             #
1001             # Latin-10 upper case without parameter
1002             #
1003             sub Elatin10::uc_() {
1004 0     0 0 0 my $s = $_;
1005 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1006             }
1007              
1008             #
1009             # Latin-10 fold case with parameter
1010             #
1011             sub Elatin10::fc(@) {
1012 197 50   197 0 211 if (@_) {
1013 197         155 my $s = shift @_;
1014 197 50 33     313 if (@_ and wantarray) {
1015 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1016             }
1017             else {
1018 197 100       398 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         944  
1019             }
1020             }
1021             else {
1022 0         0 return Elatin10::fc_();
1023             }
1024             }
1025              
1026             #
1027             # Latin-10 fold case without parameter
1028             #
1029             sub Elatin10::fc_() {
1030 0     0 0 0 my $s = $_;
1031 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1032             }
1033              
1034             #
1035             # Latin-10 regexp capture
1036             #
1037             {
1038             sub Elatin10::capture {
1039 0     0 1 0 return $_[0];
1040             }
1041             }
1042              
1043             #
1044             # Latin-10 regexp ignore case modifier
1045             #
1046             sub Elatin10::ignorecase {
1047              
1048 0     0 0 0 my @string = @_;
1049 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1050              
1051             # ignore case of $scalar or @array
1052 0         0 for my $string (@string) {
1053              
1054             # split regexp
1055 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1056              
1057             # unescape character
1058 0         0 for (my $i=0; $i <= $#char; $i++) {
1059 0 0       0 next if not defined $char[$i];
1060              
1061             # open character class [...]
1062 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1063 0         0 my $left = $i;
1064              
1065             # [] make die "unmatched [] in regexp ...\n"
1066              
1067 0 0       0 if ($char[$i+1] eq ']') {
1068 0         0 $i++;
1069             }
1070              
1071 0         0 while (1) {
1072 0 0       0 if (++$i > $#char) {
1073 0         0 croak "Unmatched [] in regexp";
1074             }
1075 0 0       0 if ($char[$i] eq ']') {
1076 0         0 my $right = $i;
1077 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1078              
1079             # escape character
1080 0         0 for my $char (@charlist) {
1081 0 0       0 if (0) {
1082             }
1083              
1084 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1085 0         0 $char = '\\' . $char;
1086             }
1087             }
1088              
1089             # [...]
1090 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1091              
1092 0         0 $i = $left;
1093 0         0 last;
1094             }
1095             }
1096             }
1097              
1098             # open character class [^...]
1099             elsif ($char[$i] eq '[^') {
1100 0         0 my $left = $i;
1101              
1102             # [^] make die "unmatched [] in regexp ...\n"
1103              
1104 0 0       0 if ($char[$i+1] eq ']') {
1105 0         0 $i++;
1106             }
1107              
1108 0         0 while (1) {
1109 0 0       0 if (++$i > $#char) {
1110 0         0 croak "Unmatched [] in regexp";
1111             }
1112 0 0       0 if ($char[$i] eq ']') {
1113 0         0 my $right = $i;
1114 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1115              
1116             # escape character
1117 0         0 for my $char (@charlist) {
1118 0 0       0 if (0) {
1119             }
1120              
1121 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1122 0         0 $char = '\\' . $char;
1123             }
1124             }
1125              
1126             # [^...]
1127 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1128              
1129 0         0 $i = $left;
1130 0         0 last;
1131             }
1132             }
1133             }
1134              
1135             # rewrite classic character class or escape character
1136             elsif (my $char = classic_character_class($char[$i])) {
1137 0         0 $char[$i] = $char;
1138             }
1139              
1140             # with /i modifier
1141             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1142 0         0 my $uc = Elatin10::uc($char[$i]);
1143 0         0 my $fc = Elatin10::fc($char[$i]);
1144 0 0       0 if ($uc ne $fc) {
1145 0 0       0 if (CORE::length($fc) == 1) {
1146 0         0 $char[$i] = '[' . $uc . $fc . ']';
1147             }
1148             else {
1149 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1150             }
1151             }
1152             }
1153             }
1154              
1155             # characterize
1156 0         0 for (my $i=0; $i <= $#char; $i++) {
1157 0 0       0 next if not defined $char[$i];
1158              
1159 0 0       0 if (0) {
1160             }
1161              
1162             # quote character before ? + * {
1163 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1164 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1165 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1166             }
1167             }
1168             }
1169              
1170 0         0 $string = join '', @char;
1171             }
1172              
1173             # make regexp string
1174 0         0 return @string;
1175             }
1176              
1177             #
1178             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1179             #
1180             sub Elatin10::classic_character_class {
1181 1862     1862 0 1483 my($char) = @_;
1182              
1183             return {
1184             '\D' => '${Elatin10::eD}',
1185             '\S' => '${Elatin10::eS}',
1186             '\W' => '${Elatin10::eW}',
1187             '\d' => '[0-9]',
1188              
1189             # Before Perl 5.6, \s only matched the five whitespace characters
1190             # tab, newline, form-feed, carriage return, and the space character
1191             # itself, which, taken together, is the character class [\t\n\f\r ].
1192              
1193             # Vertical tabs are now whitespace
1194             # \s in a regex now matches a vertical tab in all circumstances.
1195             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1196             # \t \n \v \f \r space
1197             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1198             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1199             '\s' => '\s',
1200              
1201             '\w' => '[0-9A-Z_a-z]',
1202             '\C' => '[\x00-\xFF]',
1203             '\X' => 'X',
1204              
1205             # \h \v \H \V
1206              
1207             # P.114 Character Class Shortcuts
1208             # in Chapter 7: In the World of Regular Expressions
1209             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1210              
1211             # P.357 13.2.3 Whitespace
1212             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1213             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1214             #
1215             # 0x00009 CHARACTER TABULATION h s
1216             # 0x0000a LINE FEED (LF) vs
1217             # 0x0000b LINE TABULATION v
1218             # 0x0000c FORM FEED (FF) vs
1219             # 0x0000d CARRIAGE RETURN (CR) vs
1220             # 0x00020 SPACE h s
1221              
1222             # P.196 Table 5-9. Alphanumeric regex metasymbols
1223             # in Chapter 5. Pattern Matching
1224             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1225              
1226             # (and so on)
1227              
1228             '\H' => '${Elatin10::eH}',
1229             '\V' => '${Elatin10::eV}',
1230             '\h' => '[\x09\x20]',
1231             '\v' => '[\x0A\x0B\x0C\x0D]',
1232             '\R' => '${Elatin10::eR}',
1233              
1234             # \N
1235             #
1236             # http://perldoc.perl.org/perlre.html
1237             # Character Classes and other Special Escapes
1238             # Any character but \n (experimental). Not affected by /s modifier
1239              
1240             '\N' => '${Elatin10::eN}',
1241              
1242             # \b \B
1243              
1244             # P.180 Boundaries: The \b and \B Assertions
1245             # in Chapter 5: Pattern Matching
1246             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1247              
1248             # P.219 Boundaries: The \b and \B Assertions
1249             # in Chapter 5: Pattern Matching
1250             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1251              
1252             # \b really means (?:(?<=\w)(?!\w)|(?
1253             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1254             '\b' => '${Elatin10::eb}',
1255              
1256             # \B really means (?:(?<=\w)(?=\w)|(?
1257             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1258             '\B' => '${Elatin10::eB}',
1259              
1260 1862   100     62245 }->{$char} || '';
1261             }
1262              
1263             #
1264             # prepare Latin-10 characters per length
1265             #
1266              
1267             # 1 octet characters
1268             my @chars1 = ();
1269             sub chars1 {
1270 0 0   0 0 0 if (@chars1) {
1271 0         0 return @chars1;
1272             }
1273 0 0       0 if (exists $range_tr{1}) {
1274 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1275 0         0 while (my @range = splice(@ranges,0,1)) {
1276 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1277 0         0 push @chars1, pack 'C', $oct0;
1278             }
1279             }
1280             }
1281 0         0 return @chars1;
1282             }
1283              
1284             # 2 octets characters
1285             my @chars2 = ();
1286             sub chars2 {
1287 0 0   0 0 0 if (@chars2) {
1288 0         0 return @chars2;
1289             }
1290 0 0       0 if (exists $range_tr{2}) {
1291 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1292 0         0 while (my @range = splice(@ranges,0,2)) {
1293 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1294 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1295 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1296             }
1297             }
1298             }
1299             }
1300 0         0 return @chars2;
1301             }
1302              
1303             # 3 octets characters
1304             my @chars3 = ();
1305             sub chars3 {
1306 0 0   0 0 0 if (@chars3) {
1307 0         0 return @chars3;
1308             }
1309 0 0       0 if (exists $range_tr{3}) {
1310 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1311 0         0 while (my @range = splice(@ranges,0,3)) {
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 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1316             }
1317             }
1318             }
1319             }
1320             }
1321 0         0 return @chars3;
1322             }
1323              
1324             # 4 octets characters
1325             my @chars4 = ();
1326             sub chars4 {
1327 0 0   0 0 0 if (@chars4) {
1328 0         0 return @chars4;
1329             }
1330 0 0       0 if (exists $range_tr{4}) {
1331 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1332 0         0 while (my @range = splice(@ranges,0,4)) {
1333 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1334 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1335 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1336 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1337 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1338             }
1339             }
1340             }
1341             }
1342             }
1343             }
1344 0         0 return @chars4;
1345             }
1346              
1347             #
1348             # Latin-10 open character list for tr
1349             #
1350             sub _charlist_tr {
1351              
1352 0     0   0 local $_ = shift @_;
1353              
1354             # unescape character
1355 0         0 my @char = ();
1356 0         0 while (not /\G \z/oxmsgc) {
1357 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1358 0         0 push @char, '\-';
1359             }
1360             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1361 0         0 push @char, CORE::chr(oct $1);
1362             }
1363             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1364 0         0 push @char, CORE::chr(hex $1);
1365             }
1366             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1367 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1368             }
1369             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1370             push @char, {
1371             '\0' => "\0",
1372             '\n' => "\n",
1373             '\r' => "\r",
1374             '\t' => "\t",
1375             '\f' => "\f",
1376             '\b' => "\x08", # \b means backspace in character class
1377             '\a' => "\a",
1378             '\e' => "\e",
1379 0         0 }->{$1};
1380             }
1381             elsif (/\G \\ ($q_char) /oxmsgc) {
1382 0         0 push @char, $1;
1383             }
1384             elsif (/\G ($q_char) /oxmsgc) {
1385 0         0 push @char, $1;
1386             }
1387             }
1388              
1389             # join separated multiple-octet
1390 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1391              
1392             # unescape '-'
1393 0         0 my @i = ();
1394 0         0 for my $i (0 .. $#char) {
1395 0 0       0 if ($char[$i] eq '\-') {
    0          
1396 0         0 $char[$i] = '-';
1397             }
1398             elsif ($char[$i] eq '-') {
1399 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1400 0         0 push @i, $i;
1401             }
1402             }
1403             }
1404              
1405             # open character list (reverse for splice)
1406 0         0 for my $i (CORE::reverse @i) {
1407 0         0 my @range = ();
1408              
1409             # range error
1410 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1411 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1412             }
1413              
1414             # range of multiple-octet code
1415 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1416 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1417 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1418             }
1419             elsif (CORE::length($char[$i+1]) == 2) {
1420 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1421 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1422             }
1423             elsif (CORE::length($char[$i+1]) == 3) {
1424 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1425 0         0 push @range, chars2();
1426 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1427             }
1428             elsif (CORE::length($char[$i+1]) == 4) {
1429 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1430 0         0 push @range, chars2();
1431 0         0 push @range, chars3();
1432 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1433             }
1434             else {
1435 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1436             }
1437             }
1438             elsif (CORE::length($char[$i-1]) == 2) {
1439 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1440 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1441             }
1442             elsif (CORE::length($char[$i+1]) == 3) {
1443 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1444 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1445             }
1446             elsif (CORE::length($char[$i+1]) == 4) {
1447 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1448 0         0 push @range, chars3();
1449 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1450             }
1451             else {
1452 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1453             }
1454             }
1455             elsif (CORE::length($char[$i-1]) == 3) {
1456 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1457 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1458             }
1459             elsif (CORE::length($char[$i+1]) == 4) {
1460 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1461 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1462             }
1463             else {
1464 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1465             }
1466             }
1467             elsif (CORE::length($char[$i-1]) == 4) {
1468 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1469 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1470             }
1471             else {
1472 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1473             }
1474             }
1475             else {
1476 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1477             }
1478              
1479 0         0 splice @char, $i-1, 3, @range;
1480             }
1481              
1482 0         0 return @char;
1483             }
1484              
1485             #
1486             # Latin-10 open character class
1487             #
1488             sub _cc {
1489 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1490 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1491             }
1492             elsif (scalar(@_) == 1) {
1493 0         0 return sprintf('\x%02X',$_[0]);
1494             }
1495             elsif (scalar(@_) == 2) {
1496 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1497 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1498             }
1499             elsif ($_[0] == $_[1]) {
1500 0         0 return sprintf('\x%02X',$_[0]);
1501             }
1502             elsif (($_[0]+1) == $_[1]) {
1503 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1504             }
1505             else {
1506 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1507             }
1508             }
1509             else {
1510 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1511             }
1512             }
1513              
1514             #
1515             # Latin-10 octet range
1516             #
1517             sub _octets {
1518 182     182   244 my $length = shift @_;
1519              
1520 182 50       268 if ($length == 1) {
1521 182         442 my($a1) = unpack 'C', $_[0];
1522 182         241 my($z1) = unpack 'C', $_[1];
1523              
1524 182 50       290 if ($a1 > $z1) {
1525 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1526             }
1527              
1528 182 50       397 if ($a1 == $z1) {
    50          
1529 0         0 return sprintf('\x%02X',$a1);
1530             }
1531             elsif (($a1+1) == $z1) {
1532 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1533             }
1534             else {
1535 182         1142 return sprintf('\x%02X-\x%02X',$a1,$z1);
1536             }
1537             }
1538             else {
1539 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1540             }
1541             }
1542              
1543             #
1544             # Latin-10 range regexp
1545             #
1546             sub _range_regexp {
1547 182     182   270 my($length,$first,$last) = @_;
1548              
1549 182         194 my @range_regexp = ();
1550 182 50       395 if (not exists $range_tr{$length}) {
1551 0         0 return @range_regexp;
1552             }
1553              
1554 182         138 my @ranges = @{ $range_tr{$length} };
  182         340  
1555 182         511 while (my @range = splice(@ranges,0,$length)) {
1556 182         188 my $min = '';
1557 182         153 my $max = '';
1558 182         373 for (my $i=0; $i < $length; $i++) {
1559 182         629 $min .= pack 'C', $range[$i][0];
1560 182         401 $max .= pack 'C', $range[$i][-1];
1561             }
1562              
1563             # min___max
1564             # FIRST_____________LAST
1565             # (nothing)
1566              
1567 182 50 33     1919 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1568             }
1569              
1570             # **********
1571             # min_________max
1572             # FIRST_____________LAST
1573             # **********
1574              
1575             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1576 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1577             }
1578              
1579             # **********************
1580             # min________________max
1581             # FIRST_____________LAST
1582             # **********************
1583              
1584             elsif (($min eq $first) and ($max eq $last)) {
1585 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1586             }
1587              
1588             # *********
1589             # min___max
1590             # FIRST_____________LAST
1591             # *********
1592              
1593             elsif (($first le $min) and ($max le $last)) {
1594 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1595             }
1596              
1597             # **********************
1598             # min__________________________max
1599             # FIRST_____________LAST
1600             # **********************
1601              
1602             elsif (($min le $first) and ($last le $max)) {
1603 182         355 push @range_regexp, _octets($length,$first,$last,$min,$max);
1604             }
1605              
1606             # *********
1607             # min________max
1608             # FIRST_____________LAST
1609             # *********
1610              
1611             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1612 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1613             }
1614              
1615             # min___max
1616             # FIRST_____________LAST
1617             # (nothing)
1618              
1619             elsif ($last lt $min) {
1620             }
1621              
1622             else {
1623 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1624             }
1625             }
1626              
1627 182         343 return @range_regexp;
1628             }
1629              
1630             #
1631             # Latin-10 open character list for qr and not qr
1632             #
1633             sub _charlist {
1634              
1635 358     358   400 my $modifier = pop @_;
1636 358         560 my @char = @_;
1637              
1638 358 100       626 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1639              
1640             # unescape character
1641 358         1392 for (my $i=0; $i <= $#char; $i++) {
1642              
1643             # escape - to ...
1644 1125 100 100     8242 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1645 206 100 100     804 if ((0 < $i) and ($i < $#char)) {
1646 182         338 $char[$i] = '...';
1647             }
1648             }
1649              
1650             # octal escape sequence
1651             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1652 0         0 $char[$i] = octchr($1);
1653             }
1654              
1655             # hexadecimal escape sequence
1656             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1657 0         0 $char[$i] = hexchr($1);
1658             }
1659              
1660             # \b{...} --> b\{...}
1661             # \B{...} --> B\{...}
1662             # \N{CHARNAME} --> N\{CHARNAME}
1663             # \p{PROPERTY} --> p\{PROPERTY}
1664             # \P{PROPERTY} --> P\{PROPERTY}
1665             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1666 0         0 $char[$i] = $1 . '\\' . $2;
1667             }
1668              
1669             # \p, \P, \X --> p, P, X
1670             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1671 0         0 $char[$i] = $1;
1672             }
1673              
1674             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1675 0         0 $char[$i] = CORE::chr oct $1;
1676             }
1677             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1678 22         97 $char[$i] = CORE::chr hex $1;
1679             }
1680             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1681 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1682             }
1683             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1684             $char[$i] = {
1685             '\0' => "\0",
1686             '\n' => "\n",
1687             '\r' => "\r",
1688             '\t' => "\t",
1689             '\f' => "\f",
1690             '\b' => "\x08", # \b means backspace in character class
1691             '\a' => "\a",
1692             '\e' => "\e",
1693             '\d' => '[0-9]',
1694              
1695             # Vertical tabs are now whitespace
1696             # \s in a regex now matches a vertical tab in all circumstances.
1697             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1698             # \t \n \v \f \r space
1699             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1700             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1701             '\s' => '\s',
1702              
1703             '\w' => '[0-9A-Z_a-z]',
1704             '\D' => '${Elatin10::eD}',
1705             '\S' => '${Elatin10::eS}',
1706             '\W' => '${Elatin10::eW}',
1707              
1708             '\H' => '${Elatin10::eH}',
1709             '\V' => '${Elatin10::eV}',
1710             '\h' => '[\x09\x20]',
1711             '\v' => '[\x0A\x0B\x0C\x0D]',
1712             '\R' => '${Elatin10::eR}',
1713              
1714 25         377 }->{$1};
1715             }
1716              
1717             # POSIX-style character classes
1718             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1719             $char[$i] = {
1720              
1721             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1722             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1723             '[:^lower:]' => '${Elatin10::not_lower_i}',
1724             '[:^upper:]' => '${Elatin10::not_upper_i}',
1725              
1726 8         50 }->{$1};
1727             }
1728             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1729             $char[$i] = {
1730              
1731             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1732             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1733             '[:ascii:]' => '[\x00-\x7F]',
1734             '[:blank:]' => '[\x09\x20]',
1735             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1736             '[:digit:]' => '[\x30-\x39]',
1737             '[:graph:]' => '[\x21-\x7F]',
1738             '[:lower:]' => '[\x61-\x7A]',
1739             '[:print:]' => '[\x20-\x7F]',
1740             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1741              
1742             # P.174 POSIX-Style Character Classes
1743             # in Chapter 5: Pattern Matching
1744             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1745              
1746             # P.311 11.2.4 Character Classes and other Special Escapes
1747             # in Chapter 11: perlre: Perl regular expressions
1748             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1749              
1750             # P.210 POSIX-Style Character Classes
1751             # in Chapter 5: Pattern Matching
1752             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1753              
1754             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1755              
1756             '[:upper:]' => '[\x41-\x5A]',
1757             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1758             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1759             '[:^alnum:]' => '${Elatin10::not_alnum}',
1760             '[:^alpha:]' => '${Elatin10::not_alpha}',
1761             '[:^ascii:]' => '${Elatin10::not_ascii}',
1762             '[:^blank:]' => '${Elatin10::not_blank}',
1763             '[:^cntrl:]' => '${Elatin10::not_cntrl}',
1764             '[:^digit:]' => '${Elatin10::not_digit}',
1765             '[:^graph:]' => '${Elatin10::not_graph}',
1766             '[:^lower:]' => '${Elatin10::not_lower}',
1767             '[:^print:]' => '${Elatin10::not_print}',
1768             '[:^punct:]' => '${Elatin10::not_punct}',
1769             '[:^space:]' => '${Elatin10::not_space}',
1770             '[:^upper:]' => '${Elatin10::not_upper}',
1771             '[:^word:]' => '${Elatin10::not_word}',
1772             '[:^xdigit:]' => '${Elatin10::not_xdigit}',
1773              
1774 70         1042 }->{$1};
1775             }
1776             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1777 7         28 $char[$i] = $1;
1778             }
1779             }
1780              
1781             # open character list
1782 358         444 my @singleoctet = ();
1783 358         355 my @multipleoctet = ();
1784 358         696 for (my $i=0; $i <= $#char; ) {
1785              
1786             # escaped -
1787 943 100 100     3755 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1788 182         157 $i += 1;
1789 182         323 next;
1790             }
1791              
1792             # make range regexp
1793             elsif ($char[$i] eq '...') {
1794              
1795             # range error
1796 182 50       617 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1797 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1798             }
1799             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1800 182 50       405 if ($char[$i-1] gt $char[$i+1]) {
1801 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]);
1802             }
1803             }
1804              
1805             # make range regexp per length
1806 182         474 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1807 182         187 my @regexp = ();
1808              
1809             # is first and last
1810 182 50 33     701 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1811 182         422 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1812             }
1813              
1814             # is first
1815             elsif ($length == CORE::length($char[$i-1])) {
1816 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1817             }
1818              
1819             # is inside in first and last
1820             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1821 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1822             }
1823              
1824             # is last
1825             elsif ($length == CORE::length($char[$i+1])) {
1826 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1827             }
1828              
1829             else {
1830 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1831             }
1832              
1833 182 50       328 if ($length == 1) {
1834 182         329 push @singleoctet, @regexp;
1835             }
1836             else {
1837 0         0 push @multipleoctet, @regexp;
1838             }
1839             }
1840              
1841 182         363 $i += 2;
1842             }
1843              
1844             # with /i modifier
1845             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1846 493 100       547 if ($modifier =~ /i/oxms) {
1847 24         33 my $uc = Elatin10::uc($char[$i]);
1848 24         36 my $fc = Elatin10::fc($char[$i]);
1849 24 100       35 if ($uc ne $fc) {
1850 12 50       36 if (CORE::length($fc) == 1) {
1851 12         14 push @singleoctet, $uc, $fc;
1852             }
1853             else {
1854 0         0 push @singleoctet, $uc;
1855 0         0 push @multipleoctet, $fc;
1856             }
1857             }
1858             else {
1859 12         21 push @singleoctet, $char[$i];
1860             }
1861             }
1862             else {
1863 469         478 push @singleoctet, $char[$i];
1864             }
1865 493         669 $i += 1;
1866             }
1867              
1868             # single character of single octet code
1869             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1870 0         0 push @singleoctet, "\t", "\x20";
1871 0         0 $i += 1;
1872             }
1873             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1874 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1875 0         0 $i += 1;
1876             }
1877             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1878 2         4 push @singleoctet, $char[$i];
1879 2         4 $i += 1;
1880             }
1881              
1882             # single character of multiple-octet code
1883             else {
1884 84         111 push @multipleoctet, $char[$i];
1885 84         140 $i += 1;
1886             }
1887             }
1888              
1889             # quote metachar
1890 358         574 for (@singleoctet) {
1891 689 50       2767 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1892 0         0 $_ = '-';
1893             }
1894             elsif (/\A \n \z/oxms) {
1895 8         16 $_ = '\n';
1896             }
1897             elsif (/\A \r \z/oxms) {
1898 8         14 $_ = '\r';
1899             }
1900             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1901 60         160 $_ = sprintf('\x%02X', CORE::ord $1);
1902             }
1903             elsif (/\A [\x00-\xFF] \z/oxms) {
1904 429         459 $_ = quotemeta $_;
1905             }
1906             }
1907              
1908             # return character list
1909 358         885 return \@singleoctet, \@multipleoctet;
1910             }
1911              
1912             #
1913             # Latin-10 octal escape sequence
1914             #
1915             sub octchr {
1916 5     5 0 10 my($octdigit) = @_;
1917              
1918 5         6 my @binary = ();
1919 5         13 for my $octal (split(//,$octdigit)) {
1920             push @binary, {
1921             '0' => '000',
1922             '1' => '001',
1923             '2' => '010',
1924             '3' => '011',
1925             '4' => '100',
1926             '5' => '101',
1927             '6' => '110',
1928             '7' => '111',
1929 50         140 }->{$octal};
1930             }
1931 5         13 my $binary = join '', @binary;
1932              
1933             my $octchr = {
1934             # 1234567
1935             1 => pack('B*', "0000000$binary"),
1936             2 => pack('B*', "000000$binary"),
1937             3 => pack('B*', "00000$binary"),
1938             4 => pack('B*', "0000$binary"),
1939             5 => pack('B*', "000$binary"),
1940             6 => pack('B*', "00$binary"),
1941             7 => pack('B*', "0$binary"),
1942             0 => pack('B*', "$binary"),
1943              
1944 5         55 }->{CORE::length($binary) % 8};
1945              
1946 5         15 return $octchr;
1947             }
1948              
1949             #
1950             # Latin-10 hexadecimal escape sequence
1951             #
1952             sub hexchr {
1953 5     5 0 9 my($hexdigit) = @_;
1954              
1955             my $hexchr = {
1956             1 => pack('H*', "0$hexdigit"),
1957             0 => pack('H*', "$hexdigit"),
1958              
1959 5         42 }->{CORE::length($_[0]) % 2};
1960              
1961 5         15 return $hexchr;
1962             }
1963              
1964             #
1965             # Latin-10 open character list for qr
1966             #
1967             sub charlist_qr {
1968              
1969 314     314 0 453 my $modifier = pop @_;
1970 314         609 my @char = @_;
1971              
1972 314         578 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1973 314         509 my @singleoctet = @$singleoctet;
1974 314         354 my @multipleoctet = @$multipleoctet;
1975              
1976             # return character list
1977 314 100       595 if (scalar(@singleoctet) >= 1) {
1978              
1979             # with /i modifier
1980 236 100       420 if ($modifier =~ m/i/oxms) {
1981 22         31 my %singleoctet_ignorecase = ();
1982 22         27 for (@singleoctet) {
1983 46   100     185 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1984 46         100 for my $ord (hex($1) .. hex($2)) {
1985 66         64 my $char = CORE::chr($ord);
1986 66         69 my $uc = Elatin10::uc($char);
1987 66         77 my $fc = Elatin10::fc($char);
1988 66 100       86 if ($uc eq $fc) {
1989 12         82 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1990             }
1991             else {
1992 54 50       62 if (CORE::length($fc) == 1) {
1993 54         87 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1994 54         179 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1995             }
1996             else {
1997 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1998 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1999             }
2000             }
2001             }
2002             }
2003 46 50       82 if ($_ ne '') {
2004 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2005             }
2006             }
2007 22         20 my $i = 0;
2008 22         23 my @singleoctet_ignorecase = ();
2009 22         27 for my $ord (0 .. 255) {
2010 5632 100       4761 if (exists $singleoctet_ignorecase{$ord}) {
2011 96         62 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         136  
2012             }
2013             else {
2014 5536         3476 $i++;
2015             }
2016             }
2017 22         33 @singleoctet = ();
2018 22         41 for my $range (@singleoctet_ignorecase) {
2019 3648 100       4709 if (ref $range) {
2020 56 100       37 if (scalar(@{$range}) == 1) {
  56 50       69  
2021 36         26 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         107  
2022             }
2023 20         20 elsif (scalar(@{$range}) == 2) {
2024 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2025             }
2026             else {
2027 20         18 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         15  
  20         61  
2028             }
2029             }
2030             }
2031             }
2032              
2033 236         248 my $not_anchor = '';
2034              
2035 236         489 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2036             }
2037 314 100       497 if (scalar(@multipleoctet) >= 2) {
2038 6         25 return '(?:' . join('|', @multipleoctet) . ')';
2039             }
2040             else {
2041 308         1076 return $multipleoctet[0];
2042             }
2043             }
2044              
2045             #
2046             # Latin-10 open character list for not qr
2047             #
2048             sub charlist_not_qr {
2049              
2050 44     44 0 67 my $modifier = pop @_;
2051 44         86 my @char = @_;
2052              
2053 44         107 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2054 44         77 my @singleoctet = @$singleoctet;
2055 44         50 my @multipleoctet = @$multipleoctet;
2056              
2057             # with /i modifier
2058 44 100       91 if ($modifier =~ m/i/oxms) {
2059 10         15 my %singleoctet_ignorecase = ();
2060 10         15 for (@singleoctet) {
2061 10   66     49 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2062 10         38 for my $ord (hex($1) .. hex($2)) {
2063 30         47 my $char = CORE::chr($ord);
2064 30         43 my $uc = Elatin10::uc($char);
2065 30         43 my $fc = Elatin10::fc($char);
2066 30 50       44 if ($uc eq $fc) {
2067 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2068             }
2069             else {
2070 30 50       38 if (CORE::length($fc) == 1) {
2071 30         69 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2072 30         97 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2073             }
2074             else {
2075 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2076 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2077             }
2078             }
2079             }
2080             }
2081 10 50       21 if ($_ ne '') {
2082 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2083             }
2084             }
2085 10         11 my $i = 0;
2086 10         8 my @singleoctet_ignorecase = ();
2087 10         14 for my $ord (0 .. 255) {
2088 2560 100       2440 if (exists $singleoctet_ignorecase{$ord}) {
2089 60         37 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         88  
2090             }
2091             else {
2092 2500         1786 $i++;
2093             }
2094             }
2095 10         18 @singleoctet = ();
2096 10         24 for my $range (@singleoctet_ignorecase) {
2097 960 100       1499 if (ref $range) {
2098 20 50       19 if (scalar(@{$range}) == 1) {
  20 50       31  
2099 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2100             }
2101 20         29 elsif (scalar(@{$range}) == 2) {
2102 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2103             }
2104             else {
2105 20         17 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         25  
  20         96  
2106             }
2107             }
2108             }
2109             }
2110              
2111             # return character list
2112 44 50       84 if (scalar(@multipleoctet) >= 1) {
2113 0 0       0 if (scalar(@singleoctet) >= 1) {
2114              
2115             # any character other than multiple-octet and single octet character class
2116 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2117             }
2118             else {
2119              
2120             # any character other than multiple-octet character class
2121 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2122             }
2123             }
2124             else {
2125 44 50       73 if (scalar(@singleoctet) >= 1) {
2126              
2127             # any character other than single octet character class
2128 44         222 return '(?:[^' . join('', @singleoctet) . '])';
2129             }
2130             else {
2131              
2132             # any character
2133 0         0 return "(?:$your_char)";
2134             }
2135             }
2136             }
2137              
2138             #
2139             # open file in read mode
2140             #
2141             sub _open_r {
2142 400     400   4535 my(undef,$file) = @_;
2143 400         1673 $file =~ s#\A (\s) #./$1#oxms;
2144 400   33     28011 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2145             open($_[0],"< $file\0");
2146             }
2147              
2148             #
2149             # open file in write mode
2150             #
2151             sub _open_w {
2152 0     0   0 my(undef,$file) = @_;
2153 0         0 $file =~ s#\A (\s) #./$1#oxms;
2154 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2155             open($_[0],"> $file\0");
2156             }
2157              
2158             #
2159             # open file in append mode
2160             #
2161             sub _open_a {
2162 0     0   0 my(undef,$file) = @_;
2163 0         0 $file =~ s#\A (\s) #./$1#oxms;
2164 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2165             open($_[0],">> $file\0");
2166             }
2167              
2168             #
2169             # safe system
2170             #
2171             sub _systemx {
2172              
2173             # P.707 29.2.33. exec
2174             # in Chapter 29: Functions
2175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2176             #
2177             # Be aware that in older releases of Perl, exec (and system) did not flush
2178             # your output buffer, so you needed to enable command buffering by setting $|
2179             # on one or more filehandles to avoid lost output in the case of exec, or
2180             # misordererd output in the case of system. This situation was largely remedied
2181             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2182              
2183             # P.855 exec
2184             # in Chapter 27: Functions
2185             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2186             #
2187             # In very old release of Perl (before v5.6), exec (and system) did not flush
2188             # your output buffer, so you needed to enable command buffering by setting $|
2189             # on one or more filehandles to avoid lost output with exec or misordered
2190             # output with system.
2191              
2192 200     200   621 $| = 1;
2193              
2194             # P.565 23.1.2. Cleaning Up Your Environment
2195             # in Chapter 23: Security
2196             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2197              
2198             # P.656 Cleaning Up Your Environment
2199             # in Chapter 20: Security
2200             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2201              
2202             # local $ENV{'PATH'} = '.';
2203 200         1420 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2204              
2205             # P.707 29.2.33. exec
2206             # in Chapter 29: Functions
2207             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2208             #
2209             # As we mentioned earlier, exec treats a discrete list of arguments as an
2210             # indication that it should bypass shell processing. However, there is one
2211             # place where you might still get tripped up. The exec call (and system, too)
2212             # will not 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             # or die "exec: $!"; # because @args == 1
2218             #
2219             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2220             # first 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             # or die "can't exec @args: $!";
2225              
2226             # P.855 exec
2227             # in Chapter 27: Functions
2228             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2229             #
2230             # As we mentioned earlier, exec treats a discrete list of arguments as a
2231             # directive to bypass shell processing. However, there is one place where
2232             # you might still get tripped up. The exec call (and system, too) cannot
2233             # distinguish between a single scalar argument and an array containing
2234             # only one element.
2235             #
2236             # @args = ("echo surprise"); # just one element in list
2237             # exec @args # still subject to shell escapes
2238             # || die "exec: $!"; # because @args == 1
2239             #
2240             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2241             # argument as the pathname, which forces the rest of the arguments to be
2242             # interpreted as a list, even if there is only one of them:
2243             #
2244             # exec { $args[0] } @args # safe even with one-argument list
2245             # || die "can't exec @args: $!";
2246              
2247 200         284 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         12984145  
2248             }
2249              
2250             #
2251             # Latin-10 order to character (with parameter)
2252             #
2253             sub Elatin10::chr(;$) {
2254              
2255 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2256              
2257 0 0       0 if ($c == 0x00) {
2258 0         0 return "\x00";
2259             }
2260             else {
2261 0         0 my @chr = ();
2262 0         0 while ($c > 0) {
2263 0         0 unshift @chr, ($c % 0x100);
2264 0         0 $c = int($c / 0x100);
2265             }
2266 0         0 return pack 'C*', @chr;
2267             }
2268             }
2269              
2270             #
2271             # Latin-10 order to character (without parameter)
2272             #
2273             sub Elatin10::chr_() {
2274              
2275 0     0 0 0 my $c = $_;
2276              
2277 0 0       0 if ($c == 0x00) {
2278 0         0 return "\x00";
2279             }
2280             else {
2281 0         0 my @chr = ();
2282 0         0 while ($c > 0) {
2283 0         0 unshift @chr, ($c % 0x100);
2284 0         0 $c = int($c / 0x100);
2285             }
2286 0         0 return pack 'C*', @chr;
2287             }
2288             }
2289              
2290             #
2291             # Latin-10 path globbing (with parameter)
2292             #
2293             sub Elatin10::glob($) {
2294              
2295 0 0   0 0 0 if (wantarray) {
2296 0         0 my @glob = _DOS_like_glob(@_);
2297 0         0 for my $glob (@glob) {
2298 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2299             }
2300 0         0 return @glob;
2301             }
2302             else {
2303 0         0 my $glob = _DOS_like_glob(@_);
2304 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2305 0         0 return $glob;
2306             }
2307             }
2308              
2309             #
2310             # Latin-10 path globbing (without parameter)
2311             #
2312             sub Elatin10::glob_() {
2313              
2314 0 0   0 0 0 if (wantarray) {
2315 0         0 my @glob = _DOS_like_glob();
2316 0         0 for my $glob (@glob) {
2317 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2318             }
2319 0         0 return @glob;
2320             }
2321             else {
2322 0         0 my $glob = _DOS_like_glob();
2323 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2324 0         0 return $glob;
2325             }
2326             }
2327              
2328             #
2329             # Latin-10 path globbing via File::DosGlob 1.10
2330             #
2331             # Often I confuse "_dosglob" and "_doglob".
2332             # So, I renamed "_dosglob" to "_DOS_like_glob".
2333             #
2334             my %iter;
2335             my %entries;
2336             sub _DOS_like_glob {
2337              
2338             # context (keyed by second cxix argument provided by core)
2339 0     0   0 my($expr,$cxix) = @_;
2340              
2341             # glob without args defaults to $_
2342 0 0       0 $expr = $_ if not defined $expr;
2343              
2344             # represents the current user's home directory
2345             #
2346             # 7.3. Expanding Tildes in Filenames
2347             # in Chapter 7. File Access
2348             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2349             #
2350             # and File::HomeDir, File::HomeDir::Windows module
2351              
2352             # DOS-like system
2353 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2354 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2355 0         0 { my_home_MSWin32() }oxmse;
2356             }
2357              
2358             # UNIX-like system
2359             else {
2360 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2361 0 0 0     0 { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2362             }
2363              
2364             # assume global context if not provided one
2365 0 0       0 $cxix = '_G_' if not defined $cxix;
2366 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2367              
2368             # if we're just beginning, do it all first
2369 0 0       0 if ($iter{$cxix} == 0) {
2370 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2371             }
2372              
2373             # chuck it all out, quick or slow
2374 0 0       0 if (wantarray) {
2375 0         0 delete $iter{$cxix};
2376 0         0 return @{delete $entries{$cxix}};
  0         0  
2377             }
2378             else {
2379 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2380 0         0 return shift @{$entries{$cxix}};
  0         0  
2381             }
2382             else {
2383             # return undef for EOL
2384 0         0 delete $iter{$cxix};
2385 0         0 delete $entries{$cxix};
2386 0         0 return undef;
2387             }
2388             }
2389             }
2390              
2391             #
2392             # Latin-10 path globbing subroutine
2393             #
2394             sub _do_glob {
2395              
2396 0     0   0 my($cond,@expr) = @_;
2397 0         0 my @glob = ();
2398 0         0 my $fix_drive_relative_paths = 0;
2399              
2400             OUTER:
2401 0         0 for my $expr (@expr) {
2402 0 0       0 next OUTER if not defined $expr;
2403 0 0       0 next OUTER if $expr eq '';
2404              
2405 0         0 my @matched = ();
2406 0         0 my @globdir = ();
2407 0         0 my $head = '.';
2408 0         0 my $pathsep = '/';
2409 0         0 my $tail;
2410              
2411             # if argument is within quotes strip em and do no globbing
2412 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2413 0         0 $expr = $1;
2414 0 0       0 if ($cond eq 'd') {
2415 0 0       0 if (-d $expr) {
2416 0         0 push @glob, $expr;
2417             }
2418             }
2419             else {
2420 0 0       0 if (-e $expr) {
2421 0         0 push @glob, $expr;
2422             }
2423             }
2424 0         0 next OUTER;
2425             }
2426              
2427             # wildcards with a drive prefix such as h:*.pm must be changed
2428             # to h:./*.pm to expand correctly
2429 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2430 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2431 0         0 $fix_drive_relative_paths = 1;
2432             }
2433             }
2434              
2435 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2436 0 0       0 if ($tail eq '') {
2437 0         0 push @glob, $expr;
2438 0         0 next OUTER;
2439             }
2440 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2441 0 0       0 if (@globdir = _do_glob('d', $head)) {
2442 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2443 0         0 next OUTER;
2444             }
2445             }
2446 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2447 0         0 $head .= $pathsep;
2448             }
2449 0         0 $expr = $tail;
2450             }
2451              
2452             # If file component has no wildcards, we can avoid opendir
2453 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2454 0 0       0 if ($head eq '.') {
2455 0         0 $head = '';
2456             }
2457 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2458 0         0 $head .= $pathsep;
2459             }
2460 0         0 $head .= $expr;
2461 0 0       0 if ($cond eq 'd') {
2462 0 0       0 if (-d $head) {
2463 0         0 push @glob, $head;
2464             }
2465             }
2466             else {
2467 0 0       0 if (-e $head) {
2468 0         0 push @glob, $head;
2469             }
2470             }
2471 0         0 next OUTER;
2472             }
2473 0 0       0 opendir(*DIR, $head) or next OUTER;
2474 0         0 my @leaf = readdir DIR;
2475 0         0 closedir DIR;
2476              
2477 0 0       0 if ($head eq '.') {
2478 0         0 $head = '';
2479             }
2480 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2481 0         0 $head .= $pathsep;
2482             }
2483              
2484 0         0 my $pattern = '';
2485 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2486 0         0 my $char = $1;
2487              
2488             # 6.9. Matching Shell Globs as Regular Expressions
2489             # in Chapter 6. Pattern Matching
2490             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2491             # (and so on)
2492              
2493 0 0       0 if ($char eq '*') {
    0          
    0          
2494 0         0 $pattern .= "(?:$your_char)*",
2495             }
2496             elsif ($char eq '?') {
2497 0         0 $pattern .= "(?:$your_char)?", # DOS style
2498             # $pattern .= "(?:$your_char)", # UNIX style
2499             }
2500             elsif ((my $fc = Elatin10::fc($char)) ne $char) {
2501 0         0 $pattern .= $fc;
2502             }
2503             else {
2504 0         0 $pattern .= quotemeta $char;
2505             }
2506             }
2507 0     0   0 my $matchsub = sub { Elatin10::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2508              
2509             # if ($@) {
2510             # print STDERR "$0: $@\n";
2511             # next OUTER;
2512             # }
2513              
2514             INNER:
2515 0         0 for my $leaf (@leaf) {
2516 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2517 0         0 next INNER;
2518             }
2519 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2520 0         0 next INNER;
2521             }
2522              
2523 0 0       0 if (&$matchsub($leaf)) {
2524 0         0 push @matched, "$head$leaf";
2525 0         0 next INNER;
2526             }
2527              
2528             # [DOS compatibility special case]
2529             # Failed, add a trailing dot and try again, but only...
2530              
2531 0 0 0     0 if (Elatin10::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2532             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2533             Elatin10::index($pattern,'\\.') != -1 # pattern has a dot.
2534             ) {
2535 0 0       0 if (&$matchsub("$leaf.")) {
2536 0         0 push @matched, "$head$leaf";
2537 0         0 next INNER;
2538             }
2539             }
2540             }
2541 0 0       0 if (@matched) {
2542 0         0 push @glob, @matched;
2543             }
2544             }
2545 0 0       0 if ($fix_drive_relative_paths) {
2546 0         0 for my $glob (@glob) {
2547 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2548             }
2549             }
2550 0         0 return @glob;
2551             }
2552              
2553             #
2554             # Latin-10 parse line
2555             #
2556             sub _parse_line {
2557              
2558 0     0   0 my($line) = @_;
2559              
2560 0         0 $line .= ' ';
2561 0         0 my @piece = ();
2562 0         0 while ($line =~ /
2563             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2564             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2565             /oxmsg
2566             ) {
2567 0 0       0 push @piece, defined($1) ? $1 : $2;
2568             }
2569 0         0 return @piece;
2570             }
2571              
2572             #
2573             # Latin-10 parse path
2574             #
2575             sub _parse_path {
2576              
2577 0     0   0 my($path,$pathsep) = @_;
2578              
2579 0         0 $path .= '/';
2580 0         0 my @subpath = ();
2581 0         0 while ($path =~ /
2582             ((?: [^\/\\] )+?) [\/\\]
2583             /oxmsg
2584             ) {
2585 0         0 push @subpath, $1;
2586             }
2587              
2588 0         0 my $tail = pop @subpath;
2589 0         0 my $head = join $pathsep, @subpath;
2590 0         0 return $head, $tail;
2591             }
2592              
2593             #
2594             # via File::HomeDir::Windows 1.00
2595             #
2596             sub my_home_MSWin32 {
2597              
2598             # A lot of unix people and unix-derived tools rely on
2599             # the ability to overload HOME. We will support it too
2600             # so that they can replace raw HOME calls with File::HomeDir.
2601 0 0 0 0 0 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2602 0         0 return $ENV{'HOME'};
2603             }
2604              
2605             # Do we have a user profile?
2606             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2607 0         0 return $ENV{'USERPROFILE'};
2608             }
2609              
2610             # Some Windows use something like $ENV{'HOME'}
2611             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2612 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2613             }
2614              
2615 0         0 return undef;
2616             }
2617              
2618             #
2619             # via File::HomeDir::Unix 1.00
2620             #
2621             sub my_home {
2622 0     0 0 0 my $home;
2623              
2624 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2625 0         0 $home = $ENV{'HOME'};
2626             }
2627              
2628             # This is from the original code, but I'm guessing
2629             # it means "login directory" and exists on some Unixes.
2630             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2631 0         0 $home = $ENV{'LOGDIR'};
2632             }
2633              
2634             ### More-desperate methods
2635              
2636             # Light desperation on any (Unixish) platform
2637             else {
2638 0         0 $home = CORE::eval q{ (getpwuid($<))[7] };
2639             }
2640              
2641             # On Unix in general, a non-existant home means "no home"
2642             # For example, "nobody"-like users might use /nonexistant
2643 0 0 0     0 if (defined $home and ! -d($home)) {
2644 0         0 $home = undef;
2645             }
2646 0         0 return $home;
2647             }
2648              
2649             #
2650             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2651             #
2652             sub Elatin10::PREMATCH {
2653 0     0 0 0 return $`;
2654             }
2655              
2656             #
2657             # ${^MATCH}, $MATCH, $& the string that matched
2658             #
2659             sub Elatin10::MATCH {
2660 0     0 0 0 return $&;
2661             }
2662              
2663             #
2664             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2665             #
2666             sub Elatin10::POSTMATCH {
2667 0     0 0 0 return $';
2668             }
2669              
2670             #
2671             # Latin-10 character to order (with parameter)
2672             #
2673             sub Latin10::ord(;$) {
2674              
2675 0 0   0 1 0 local $_ = shift if @_;
2676              
2677 0 0       0 if (/\A ($q_char) /oxms) {
2678 0         0 my @ord = unpack 'C*', $1;
2679 0         0 my $ord = 0;
2680 0         0 while (my $o = shift @ord) {
2681 0         0 $ord = $ord * 0x100 + $o;
2682             }
2683 0         0 return $ord;
2684             }
2685             else {
2686 0         0 return CORE::ord $_;
2687             }
2688             }
2689              
2690             #
2691             # Latin-10 character to order (without parameter)
2692             #
2693             sub Latin10::ord_() {
2694              
2695 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2696 0         0 my @ord = unpack 'C*', $1;
2697 0         0 my $ord = 0;
2698 0         0 while (my $o = shift @ord) {
2699 0         0 $ord = $ord * 0x100 + $o;
2700             }
2701 0         0 return $ord;
2702             }
2703             else {
2704 0         0 return CORE::ord $_;
2705             }
2706             }
2707              
2708             #
2709             # Latin-10 reverse
2710             #
2711             sub Latin10::reverse(@) {
2712              
2713 0 0   0 0 0 if (wantarray) {
2714 0         0 return CORE::reverse @_;
2715             }
2716             else {
2717              
2718             # One of us once cornered Larry in an elevator and asked him what
2719             # problem he was solving with this, but he looked as far off into
2720             # the distance as he could in an elevator and said, "It seemed like
2721             # a good idea at the time."
2722              
2723 0         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2724             }
2725             }
2726              
2727             #
2728             # Latin-10 getc (with parameter, without parameter)
2729             #
2730             sub Latin10::getc(;*@) {
2731              
2732 0     0 0 0 my($package) = caller;
2733 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2734 0 0 0     0 croak 'Too many arguments for Latin10::getc' if @_ and not wantarray;
2735              
2736 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2737 0         0 my $getc = '';
2738 0         0 for my $length ($length[0] .. $length[-1]) {
2739 0         0 $getc .= CORE::getc($fh);
2740 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2741 0 0       0 if ($getc =~ /\A ${Elatin10::dot_s} \z/oxms) {
2742 0 0       0 return wantarray ? ($getc,@_) : $getc;
2743             }
2744             }
2745             }
2746 0 0       0 return wantarray ? ($getc,@_) : $getc;
2747             }
2748              
2749             #
2750             # Latin-10 length by character
2751             #
2752             sub Latin10::length(;$) {
2753              
2754 0 0   0 1 0 local $_ = shift if @_;
2755              
2756 0         0 local @_ = /\G ($q_char) /oxmsg;
2757 0         0 return scalar @_;
2758             }
2759              
2760             #
2761             # Latin-10 substr by character
2762             #
2763             BEGIN {
2764              
2765             # P.232 The lvalue Attribute
2766             # in Chapter 6: Subroutines
2767             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2768              
2769             # P.336 The lvalue Attribute
2770             # in Chapter 7: Subroutines
2771             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2772              
2773             # P.144 8.4 Lvalue subroutines
2774             # in Chapter 8: perlsub: Perl subroutines
2775             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2776              
2777 200 50 0 200 1 91767 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  
2778             # vv----------------------*******
2779             sub Latin10::substr($$;$$) %s {
2780              
2781             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2782              
2783             # If the substring is beyond either end of the string, substr() returns the undefined
2784             # value and produces a warning. When used as an lvalue, specifying a substring that
2785             # is entirely outside the string raises an exception.
2786             # http://perldoc.perl.org/functions/substr.html
2787              
2788             # A return with no argument returns the scalar value undef in scalar context,
2789             # an empty list () in list context, and (naturally) nothing at all in void
2790             # context.
2791              
2792             my $offset = $_[1];
2793             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2794             return;
2795             }
2796              
2797             # substr($string,$offset,$length,$replacement)
2798             if (@_ == 4) {
2799             my(undef,undef,$length,$replacement) = @_;
2800             my $substr = join '', splice(@char, $offset, $length, $replacement);
2801             $_[0] = join '', @char;
2802              
2803             # return $substr; this doesn't work, don't say "return"
2804             $substr;
2805             }
2806              
2807             # substr($string,$offset,$length)
2808             elsif (@_ == 3) {
2809             my(undef,undef,$length) = @_;
2810             my $octet_offset = 0;
2811             my $octet_length = 0;
2812             if ($offset == 0) {
2813             $octet_offset = 0;
2814             }
2815             elsif ($offset > 0) {
2816             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2817             }
2818             else {
2819             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2820             }
2821             if ($length == 0) {
2822             $octet_length = 0;
2823             }
2824             elsif ($length > 0) {
2825             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2826             }
2827             else {
2828             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2829             }
2830             CORE::substr($_[0], $octet_offset, $octet_length);
2831             }
2832              
2833             # substr($string,$offset)
2834             else {
2835             my $octet_offset = 0;
2836             if ($offset == 0) {
2837             $octet_offset = 0;
2838             }
2839             elsif ($offset > 0) {
2840             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2841             }
2842             else {
2843             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2844             }
2845             CORE::substr($_[0], $octet_offset);
2846             }
2847             }
2848             END
2849             }
2850              
2851             #
2852             # Latin-10 index by character
2853             #
2854             sub Latin10::index($$;$) {
2855              
2856 0     0 1 0 my $index;
2857 0 0       0 if (@_ == 3) {
2858 0         0 $index = Elatin10::index($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2859             }
2860             else {
2861 0         0 $index = Elatin10::index($_[0], $_[1]);
2862             }
2863              
2864 0 0       0 if ($index == -1) {
2865 0         0 return -1;
2866             }
2867             else {
2868 0         0 return Latin10::length(CORE::substr $_[0], 0, $index);
2869             }
2870             }
2871              
2872             #
2873             # Latin-10 rindex by character
2874             #
2875             sub Latin10::rindex($$;$) {
2876              
2877 0     0 1 0 my $rindex;
2878 0 0       0 if (@_ == 3) {
2879 0         0 $rindex = Elatin10::rindex($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2880             }
2881             else {
2882 0         0 $rindex = Elatin10::rindex($_[0], $_[1]);
2883             }
2884              
2885 0 0       0 if ($rindex == -1) {
2886 0         0 return -1;
2887             }
2888             else {
2889 0         0 return Latin10::length(CORE::substr $_[0], 0, $rindex);
2890             }
2891             }
2892              
2893             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2894             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2895 200     200   12060 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1059  
  200         255  
  200         10064  
2896              
2897             # ord() to ord() or Latin10::ord()
2898 200     200   9815 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   763  
  200         286  
  200         8367  
2899              
2900             # ord to ord or Latin10::ord_
2901 200     200   8955 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   739  
  200         269  
  200         8232  
2902              
2903             # reverse to reverse or Latin10::reverse
2904 200     200   8797 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   696  
  200         249  
  200         8435  
2905              
2906             # getc to getc or Latin10::getc
2907 200     200   8356 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   747  
  200         236  
  200         8708  
2908              
2909             # P.1023 Appendix W.9 Multibyte Anchoring
2910             # of ISBN 1-56592-224-7 CJKV Information Processing
2911              
2912             my $anchor = '';
2913              
2914 200     200   8891 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   682  
  200         263  
  200         6649704  
2915              
2916             # regexp of nested parens in qqXX
2917              
2918             # P.340 Matching Nested Constructs with Embedded Code
2919             # in Chapter 7: Perl
2920             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2921              
2922             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2923             [^\\()] |
2924             \( (?{$nest++}) |
2925             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2926             \\ [^c] |
2927             \\c[\x40-\x5F] |
2928             [\x00-\xFF]
2929             }xms;
2930              
2931             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2932             [^\\{}] |
2933             \{ (?{$nest++}) |
2934             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2935             \\ [^c] |
2936             \\c[\x40-\x5F] |
2937             [\x00-\xFF]
2938             }xms;
2939              
2940             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2941             [^\\\[\]] |
2942             \[ (?{$nest++}) |
2943             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2944             \\ [^c] |
2945             \\c[\x40-\x5F] |
2946             [\x00-\xFF]
2947             }xms;
2948              
2949             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2950             [^\\<>] |
2951             \< (?{$nest++}) |
2952             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2953             \\ [^c] |
2954             \\c[\x40-\x5F] |
2955             [\x00-\xFF]
2956             }xms;
2957              
2958             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2959             (?: ::)? (?:
2960             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2961             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2962             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2963             ))
2964             }xms;
2965              
2966             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2967             (?: ::)? (?:
2968             (?>[0-9]+) |
2969             [^a-zA-Z_0-9\[\]] |
2970             ^[A-Z] |
2971             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2972             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2973             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2974             ))
2975             }xms;
2976              
2977             my $qq_substr = qr{(?> Char::substr | Latin10::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2978             }xms;
2979              
2980             # regexp of nested parens in qXX
2981             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2982             [^()] |
2983             \( (?{$nest++}) |
2984             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2985             [\x00-\xFF]
2986             }xms;
2987              
2988             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2989             [^\{\}] |
2990             \{ (?{$nest++}) |
2991             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2992             [\x00-\xFF]
2993             }xms;
2994              
2995             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2996             [^\[\]] |
2997             \[ (?{$nest++}) |
2998             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2999             [\x00-\xFF]
3000             }xms;
3001              
3002             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3003             [^<>] |
3004             \< (?{$nest++}) |
3005             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3006             [\x00-\xFF]
3007             }xms;
3008              
3009             my $matched = '';
3010             my $s_matched = '';
3011              
3012             my $tr_variable = ''; # variable of tr///
3013             my $sub_variable = ''; # variable of s///
3014             my $bind_operator = ''; # =~ or !~
3015              
3016             my @heredoc = (); # here document
3017             my @heredoc_delimiter = ();
3018             my $here_script = ''; # here script
3019              
3020             #
3021             # escape Latin-10 script
3022             #
3023             sub Latin10::escape(;$) {
3024 200 50   200 0 502 local($_) = $_[0] if @_;
3025              
3026             # P.359 The Study Function
3027             # in Chapter 7: Perl
3028             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3029              
3030 200         287 study $_; # Yes, I studied study yesterday.
3031              
3032             # while all script
3033              
3034             # 6.14. Matching from Where the Last Pattern Left Off
3035             # in Chapter 6. Pattern Matching
3036             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3037             # (and so on)
3038              
3039             # one member of Tag-team
3040             #
3041             # P.128 Start of match (or end of previous match): \G
3042             # P.130 Advanced Use of \G with Perl
3043             # in Chapter 3: Overview of Regular Expression Features and Flavors
3044             # P.255 Use leading anchors
3045             # P.256 Expose ^ and \G at the front expressions
3046             # in Chapter 6: Crafting an Efficient Expression
3047             # P.315 "Tag-team" matching with /gc
3048             # in Chapter 7: Perl
3049             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3050              
3051 200         274 my $e_script = '';
3052 200         696 while (not /\G \z/oxgc) { # member
3053 72148         76750 $e_script .= Latin10::escape_token();
3054             }
3055              
3056 200         1861 return $e_script;
3057             }
3058              
3059             #
3060             # escape Latin-10 token of script
3061             #
3062             sub Latin10::escape_token {
3063              
3064             # \n output here document
3065              
3066 72148     72148 0 51508 my $ignore_modules = join('|', qw(
3067             utf8
3068             bytes
3069             charnames
3070             I18N::Japanese
3071             I18N::Collate
3072             I18N::JExt
3073             File::DosGlob
3074             Wild
3075             Wildcard
3076             Japanese
3077             ));
3078              
3079             # another member of Tag-team
3080             #
3081             # P.315 "Tag-team" matching with /gc
3082             # in Chapter 7: Perl
3083             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3084              
3085 72148 100 100     3307274 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          
3086 12088         9094 my $heredoc = '';
3087 12088 100       18229 if (scalar(@heredoc_delimiter) >= 1) {
3088 150         131 $slash = 'm//';
3089              
3090 150         225 $heredoc = join '', @heredoc;
3091 150         204 @heredoc = ();
3092              
3093             # skip here document
3094 150         219 for my $heredoc_delimiter (@heredoc_delimiter) {
3095 150         867 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3096             }
3097 150         190 @heredoc_delimiter = ();
3098              
3099 150         147 $here_script = '';
3100             }
3101 12088         29013 return "\n" . $heredoc;
3102             }
3103              
3104             # ignore space, comment
3105 17337         39664 elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3106              
3107             # if (, elsif (, unless (, while (, until (, given (, and when (
3108              
3109             # given, when
3110              
3111             # P.225 The given Statement
3112             # in Chapter 15: Smart Matching and given-when
3113             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3114              
3115             # P.133 The given Statement
3116             # in Chapter 4: Statements and Declarations
3117             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3118              
3119             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3120 1373         1327 $slash = 'm//';
3121 1373         3330 return $1;
3122             }
3123              
3124             # scalar variable ($scalar = ...) =~ tr///;
3125             # scalar variable ($scalar = ...) =~ s///;
3126              
3127             # state
3128              
3129             # P.68 Persistent, Private Variables
3130             # in Chapter 4: Subroutines
3131             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3132              
3133             # P.160 Persistent Lexically Scoped Variables: state
3134             # in Chapter 4: Statements and Declarations
3135             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3136              
3137             # (and so on)
3138              
3139             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3140 85         111 my $e_string = e_string($1);
3141              
3142 85 50       1613 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3143 0         0 $tr_variable = $e_string . e_string($1);
3144 0         0 $bind_operator = $2;
3145 0         0 $slash = 'm//';
3146 0         0 return '';
3147             }
3148             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3149 0         0 $sub_variable = $e_string . e_string($1);
3150 0         0 $bind_operator = $2;
3151 0         0 $slash = 'm//';
3152 0         0 return '';
3153             }
3154             else {
3155 85         82 $slash = 'div';
3156 85         231 return $e_string;
3157             }
3158             }
3159              
3160             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
3161             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3162 4         7 $slash = 'div';
3163 4         14 return q{Elatin10::PREMATCH()};
3164             }
3165              
3166             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
3167             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3168 28         40 $slash = 'div';
3169 28         73 return q{Elatin10::MATCH()};
3170             }
3171              
3172             # $', ${'} --> $', ${'}
3173             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3174 1         1 $slash = 'div';
3175 1         3 return $1;
3176             }
3177              
3178             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
3179             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3180 3         6 $slash = 'div';
3181 3         9 return q{Elatin10::POSTMATCH()};
3182             }
3183              
3184             # scalar variable $scalar =~ tr///;
3185             # scalar variable $scalar =~ s///;
3186             # substr() =~ tr///;
3187             # substr() =~ s///;
3188             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3189 1604         2464 my $scalar = e_string($1);
3190              
3191 1604 100       5142 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3192 1         2 $tr_variable = $scalar;
3193 1         2 $bind_operator = $1;
3194 1         1 $slash = 'm//';
3195 1         2 return '';
3196             }
3197             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3198 61         91 $sub_variable = $scalar;
3199 61         89 $bind_operator = $1;
3200 61         59 $slash = 'm//';
3201 61         151 return '';
3202             }
3203             else {
3204 1542         1417 $slash = 'div';
3205 1542         3661 return $scalar;
3206             }
3207             }
3208              
3209             # end of statement
3210             elsif (/\G ( [,;] ) /oxgc) {
3211 4583         4357 $slash = 'm//';
3212              
3213             # clear tr/// variable
3214 4583         3663 $tr_variable = '';
3215              
3216             # clear s/// variable
3217 4583         3339 $sub_variable = '';
3218              
3219 4583         3143 $bind_operator = '';
3220              
3221 4583         12404 return $1;
3222             }
3223              
3224             # bareword
3225             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3226 0         0 return $1;
3227             }
3228              
3229             # $0 --> $0
3230             elsif (/\G ( \$ 0 ) /oxmsgc) {
3231 2         4 $slash = 'div';
3232 2         7 return $1;
3233             }
3234             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3235 0         0 $slash = 'div';
3236 0         0 return $1;
3237             }
3238              
3239             # $$ --> $$
3240             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3241 1         2 $slash = 'div';
3242 1         3 return $1;
3243             }
3244              
3245             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3246             # $1, $2, $3 --> $1, $2, $3 otherwise
3247             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3248 4         5 $slash = 'div';
3249 4         6 return e_capture($1);
3250             }
3251             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3252 0         0 $slash = 'div';
3253 0         0 return e_capture($1);
3254             }
3255              
3256             # $$foo[ ... ] --> $ $foo->[ ... ]
3257             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3258 0         0 $slash = 'div';
3259 0         0 return e_capture($1.'->'.$2);
3260             }
3261              
3262             # $$foo{ ... } --> $ $foo->{ ... }
3263             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3264 0         0 $slash = 'div';
3265 0         0 return e_capture($1.'->'.$2);
3266             }
3267              
3268             # $$foo
3269             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3270 0         0 $slash = 'div';
3271 0         0 return e_capture($1);
3272             }
3273              
3274             # ${ foo }
3275             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3276 0         0 $slash = 'div';
3277 0         0 return '${' . $1 . '}';
3278             }
3279              
3280             # ${ ... }
3281             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3282 0         0 $slash = 'div';
3283 0         0 return e_capture($1);
3284             }
3285              
3286             # variable or function
3287             # $ @ % & * $ #
3288             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) {
3289 42         54 $slash = 'div';
3290 42         119 return $1;
3291             }
3292             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3293             # $ @ # \ ' " / ? ( ) [ ] < >
3294             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3295 60         73 $slash = 'div';
3296 60         180 return $1;
3297             }
3298              
3299             # while ()
3300             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3301 0         0 return $1;
3302             }
3303              
3304             # while () --- glob
3305              
3306             # avoid "Error: Runtime exception" of perl version 5.005_03
3307              
3308             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3309 0         0 return 'while ($_ = Elatin10::glob("' . $1 . '"))';
3310             }
3311              
3312             # while (glob)
3313             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3314 0         0 return 'while ($_ = Elatin10::glob_)';
3315             }
3316              
3317             # while (glob(WILDCARD))
3318             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3319 0         0 return 'while ($_ = Elatin10::glob';
3320             }
3321              
3322             # doit if, doit unless, doit while, doit until, doit for, doit when
3323 241         339 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         774  
3324              
3325             # subroutines of package Elatin10
3326 19         26 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         67  
3327 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3328 13         13 elsif (/\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         26  
3329 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3330 114         102 elsif (/\G \b Latin10::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin10::escape'; }
  114         259  
3331 2         3 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3332 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chop'; }
  0         0  
3333 2         3 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
3334 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3335 0         0 elsif (/\G \b Latin10::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::index'; }
  0         0  
3336 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::index'; }
  0         0  
3337 2         3 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         6  
3338 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3339 0         0 elsif (/\G \b Latin10::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::rindex'; }
  0         0  
3340 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::rindex'; }
  0         0  
3341 1         3 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lc'; }
  1         4  
3342 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst'; }
  0         0  
3343 1         3 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::uc'; }
  1         3  
3344 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst'; }
  0         0  
3345 6         7 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::fc'; }
  6         12  
3346              
3347             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3348 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3349 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3350 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3351 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3352 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3353 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3354 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  
3355              
3356 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3357 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3358 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3359 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3360 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3361 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3362 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  
3363              
3364             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3365 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3366 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3367 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3368 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3369              
3370 2         3 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         5  
3371 2         3 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         10  
3372 36         33 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::chr'; }
  36         81  
3373 2         4 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         7  
3374 8         10 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         19  
3375 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::glob'; }
  0         0  
3376 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lc_'; }
  0         0  
3377 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst_'; }
  0         0  
3378 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::uc_'; }
  0         0  
3379 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst_'; }
  0         0  
3380 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::fc_'; }
  0         0  
3381 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3382              
3383 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3384 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3385 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chr_'; }
  0         0  
3386 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3387 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3388 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::glob_'; }
  0         0  
3389 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3390 8         14 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         32  
3391             # split
3392             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3393 87         116 $slash = 'm//';
3394              
3395 87         90 my $e = '';
3396 87         277 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3397 85         269 $e .= $1;
3398             }
3399              
3400             # end of split
3401 87 100       6259 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
  2 100       6  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3402              
3403             # split scalar value
3404 1         3 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin10::split' . $e . e_string($1); }
3405              
3406             # split literal space
3407 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {qq$1 $2}; }
3408 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3409 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3410 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3411 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3412 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3413 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {q$1 $2}; }
3414 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3415 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3416 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3417 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3418 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3419 10         34 elsif (/\G ' [ ] ' /oxgc) { return 'Elatin10::split' . $e . qq {' '}; }
3420 0         0 elsif (/\G " [ ] " /oxgc) { return 'Elatin10::split' . $e . qq {" "}; }
3421              
3422             # split qq//
3423             elsif (/\G \b (qq) \b /oxgc) {
3424 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3425             else {
3426 0         0 while (not /\G \z/oxgc) {
3427 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3428 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3429 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3430 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3431 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3432 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3433 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3434             }
3435 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3436             }
3437             }
3438              
3439             # split qr//
3440             elsif (/\G \b (qr) \b /oxgc) {
3441 12 50       481 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3442             else {
3443 12         52 while (not /\G \z/oxgc) {
3444 12 50       3152 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3445 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3446 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3447 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3448 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3449 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3450 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3451 12         61 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3452             }
3453 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3454             }
3455             }
3456              
3457             # split q//
3458             elsif (/\G \b (q) \b /oxgc) {
3459 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3460             else {
3461 0         0 while (not /\G \z/oxgc) {
3462 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3463 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3464 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3465 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3466 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3467 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3468 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3469             }
3470 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3471             }
3472             }
3473              
3474             # split m//
3475             elsif (/\G \b (m) \b /oxgc) {
3476 18 50       489 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3477             else {
3478 18         67 while (not /\G \z/oxgc) {
3479 18 50       3410 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3480 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3481 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3482 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3483 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3484 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3485 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3486 18         78 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3487             }
3488 0         0 die __FILE__, ": Search pattern not terminated\n";
3489             }
3490             }
3491              
3492             # split ''
3493             elsif (/\G (\') /oxgc) {
3494 0         0 my $q_string = '';
3495 0         0 while (not /\G \z/oxgc) {
3496 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3497 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3498 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3499 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3500             }
3501 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3502             }
3503              
3504             # split ""
3505             elsif (/\G (\") /oxgc) {
3506 0         0 my $qq_string = '';
3507 0         0 while (not /\G \z/oxgc) {
3508 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3509 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3510 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3511 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3512             }
3513 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3514             }
3515              
3516             # split //
3517             elsif (/\G (\/) /oxgc) {
3518 44         54 my $regexp = '';
3519 44         112 while (not /\G \z/oxgc) {
3520 381 50       1353 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3521 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3522 44         172 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3523 337         584 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3524             }
3525 0         0 die __FILE__, ": Search pattern not terminated\n";
3526             }
3527             }
3528              
3529             # tr/// or y///
3530              
3531             # about [cdsrbB]* (/B modifier)
3532             #
3533             # P.559 appendix C
3534             # of ISBN 4-89052-384-7 Programming perl
3535             # (Japanese title is: Perl puroguramingu)
3536              
3537             elsif (/\G \b ( tr | y ) \b /oxgc) {
3538 3         7 my $ope = $1;
3539              
3540             # $1 $2 $3 $4 $5 $6
3541 3 50       62 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3542 0         0 my @tr = ($tr_variable,$2);
3543 0         0 return e_tr(@tr,'',$4,$6);
3544             }
3545             else {
3546 3         4 my $e = '';
3547 3         6 while (not /\G \z/oxgc) {
3548 3 50       197 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3549             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3550 0         0 my @tr = ($tr_variable,$2);
3551 0         0 while (not /\G \z/oxgc) {
3552 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3553 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3554 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3555 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3556 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3557 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3558             }
3559 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3560             }
3561             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3562 0         0 my @tr = ($tr_variable,$2);
3563 0         0 while (not /\G \z/oxgc) {
3564 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3565 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3566 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3567 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3568 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3569 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3570             }
3571 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3572             }
3573             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3574 0         0 my @tr = ($tr_variable,$2);
3575 0         0 while (not /\G \z/oxgc) {
3576 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3577 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3578 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3579 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3580 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3581 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3582             }
3583 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3584             }
3585             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3586 0         0 my @tr = ($tr_variable,$2);
3587 0         0 while (not /\G \z/oxgc) {
3588 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3589 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3590 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3591 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3592 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3593 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3594             }
3595 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3596             }
3597             # $1 $2 $3 $4 $5 $6
3598             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3599 3         8 my @tr = ($tr_variable,$2);
3600 3         6 return e_tr(@tr,'',$4,$6);
3601             }
3602             }
3603 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3604             }
3605             }
3606              
3607             # qq//
3608             elsif (/\G \b (qq) \b /oxgc) {
3609 2130         3025 my $ope = $1;
3610              
3611             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3612 2130 50       2841 if (/\G (\#) /oxgc) { # qq# #
3613 0         0 my $qq_string = '';
3614 0         0 while (not /\G \z/oxgc) {
3615 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3616 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3617 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3618 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3619             }
3620 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3621             }
3622              
3623             else {
3624 2130         1815 my $e = '';
3625 2130         3914 while (not /\G \z/oxgc) {
3626 2130 50       6767 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3627              
3628             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3629             elsif (/\G (\() /oxgc) { # qq ( )
3630 0         0 my $qq_string = '';
3631 0         0 local $nest = 1;
3632 0         0 while (not /\G \z/oxgc) {
3633 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3634 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3635 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3636             elsif (/\G (\)) /oxgc) {
3637 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3638 0         0 else { $qq_string .= $1; }
3639             }
3640 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3641             }
3642 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3643             }
3644              
3645             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3646             elsif (/\G (\{) /oxgc) { # qq { }
3647 2100         1730 my $qq_string = '';
3648 2100         2153 local $nest = 1;
3649 2100         3504 while (not /\G \z/oxgc) {
3650 82657 100       235281 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1176  
    100          
    100          
    50          
3651 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3652 1103         1030 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         1592  
3653             elsif (/\G (\}) /oxgc) {
3654 3203 100       3602 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         3315  
3655 1103         1923 else { $qq_string .= $1; }
3656             }
3657 77629         121301 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3658             }
3659 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3660             }
3661              
3662             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3663             elsif (/\G (\[) /oxgc) { # qq [ ]
3664 0         0 my $qq_string = '';
3665 0         0 local $nest = 1;
3666 0         0 while (not /\G \z/oxgc) {
3667 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3668 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3669 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3670             elsif (/\G (\]) /oxgc) {
3671 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3672 0         0 else { $qq_string .= $1; }
3673             }
3674 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3675             }
3676 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3677             }
3678              
3679             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3680             elsif (/\G (\<) /oxgc) { # qq < >
3681 30         32 my $qq_string = '';
3682 30         42 local $nest = 1;
3683 30         75 while (not /\G \z/oxgc) {
3684 1166 100       3722 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       44  
    50          
    100          
    50          
3685 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3686 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3687             elsif (/\G (\>) /oxgc) {
3688 30 50       60 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         59  
3689 0         0 else { $qq_string .= $1; }
3690             }
3691 1114         1755 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3692             }
3693 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3694             }
3695              
3696             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3697             elsif (/\G (\S) /oxgc) { # qq * *
3698 0         0 my $delimiter = $1;
3699 0         0 my $qq_string = '';
3700 0         0 while (not /\G \z/oxgc) {
3701 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3702 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3703 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3704 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3705             }
3706 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3707             }
3708             }
3709 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3710             }
3711             }
3712              
3713             # qr//
3714             elsif (/\G \b (qr) \b /oxgc) {
3715 0         0 my $ope = $1;
3716 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3717 0         0 return e_qr($ope,$1,$3,$2,$4);
3718             }
3719             else {
3720 0         0 my $e = '';
3721 0         0 while (not /\G \z/oxgc) {
3722 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3723 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3724 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3725 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3726 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3727 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3728 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3729 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3730             }
3731 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3732             }
3733             }
3734              
3735             # qw//
3736             elsif (/\G \b (qw) \b /oxgc) {
3737 16         34 my $ope = $1;
3738 16 50       53 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3739 0         0 return e_qw($ope,$1,$3,$2);
3740             }
3741             else {
3742 16         18 my $e = '';
3743 16         46 while (not /\G \z/oxgc) {
3744 16 50       91 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3745              
3746 16         45 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3747 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3748              
3749 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3750 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3751              
3752 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3753 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3754              
3755 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3756 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3757              
3758 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3759 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3760             }
3761 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3762             }
3763             }
3764              
3765             # qx//
3766             elsif (/\G \b (qx) \b /oxgc) {
3767 0         0 my $ope = $1;
3768 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3769 0         0 return e_qq($ope,$1,$3,$2);
3770             }
3771             else {
3772 0         0 my $e = '';
3773 0         0 while (not /\G \z/oxgc) {
3774 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3775 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3776 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3777 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3778 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3779 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3780 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3781             }
3782 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3783             }
3784             }
3785              
3786             # q//
3787             elsif (/\G \b (q) \b /oxgc) {
3788 245         491 my $ope = $1;
3789              
3790             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3791              
3792             # avoid "Error: Runtime exception" of perl version 5.005_03
3793             # (and so on)
3794              
3795 245 50       603 if (/\G (\#) /oxgc) { # q# #
3796 0         0 my $q_string = '';
3797 0         0 while (not /\G \z/oxgc) {
3798 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3799 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3800 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3801 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3802             }
3803 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3804             }
3805              
3806             else {
3807 245         363 my $e = '';
3808 245         715 while (not /\G \z/oxgc) {
3809 245 50       1289 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3810              
3811             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3812             elsif (/\G (\() /oxgc) { # q ( )
3813 0         0 my $q_string = '';
3814 0         0 local $nest = 1;
3815 0         0 while (not /\G \z/oxgc) {
3816 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3817 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3818 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3819 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3820             elsif (/\G (\)) /oxgc) {
3821 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3822 0         0 else { $q_string .= $1; }
3823             }
3824 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3825             }
3826 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3827             }
3828              
3829             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3830             elsif (/\G (\{) /oxgc) { # q { }
3831 239         326 my $q_string = '';
3832 239         359 local $nest = 1;
3833 239         641 while (not /\G \z/oxgc) {
3834 3650 50       14892 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3835 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3836 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3837 107         111 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         164  
3838             elsif (/\G (\}) /oxgc) {
3839 346 100       592 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         626  
3840 107         184 else { $q_string .= $1; }
3841             }
3842 3197         5596 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3843             }
3844 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3845             }
3846              
3847             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3848             elsif (/\G (\[) /oxgc) { # q [ ]
3849 0         0 my $q_string = '';
3850 0         0 local $nest = 1;
3851 0         0 while (not /\G \z/oxgc) {
3852 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3853 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3854 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3855 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3856             elsif (/\G (\]) /oxgc) {
3857 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3858 0         0 else { $q_string .= $1; }
3859             }
3860 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3861             }
3862 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3863             }
3864              
3865             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3866             elsif (/\G (\<) /oxgc) { # q < >
3867 5         11 my $q_string = '';
3868 5         15 local $nest = 1;
3869 5         45 while (not /\G \z/oxgc) {
3870 88 50       405 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3871 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3872 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3873 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3874             elsif (/\G (\>) /oxgc) {
3875 5 50       11 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         14  
3876 0         0 else { $q_string .= $1; }
3877             }
3878 83         140 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3879             }
3880 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3881             }
3882              
3883             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3884             elsif (/\G (\S) /oxgc) { # q * *
3885 1         2 my $delimiter = $1;
3886 1         2 my $q_string = '';
3887 1         2 while (not /\G \z/oxgc) {
3888 14 50       67 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3889 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3890 1         2 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3891 13         21 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3892             }
3893 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3894             }
3895             }
3896 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3897             }
3898             }
3899              
3900             # m//
3901             elsif (/\G \b (m) \b /oxgc) {
3902 209         334 my $ope = $1;
3903 209 50       1582 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3904 0         0 return e_qr($ope,$1,$3,$2,$4);
3905             }
3906             else {
3907 209         227 my $e = '';
3908 209         461 while (not /\G \z/oxgc) {
3909 209 50       10528 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3910 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3911 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3912 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3913 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3914 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3915 10         26 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3916 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3917 199         463 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3918             }
3919 0         0 die __FILE__, ": Search pattern not terminated\n";
3920             }
3921             }
3922              
3923             # s///
3924              
3925             # about [cegimosxpradlunbB]* (/cg modifier)
3926             #
3927             # P.67 Pattern-Matching Operators
3928             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3929              
3930             elsif (/\G \b (s) \b /oxgc) {
3931 97         173 my $ope = $1;
3932              
3933             # $1 $2 $3 $4 $5 $6
3934 97 100       1917 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3935 1         3 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3936             }
3937             else {
3938 96         110 my $e = '';
3939 96         246 while (not /\G \z/oxgc) {
3940 96 50       10166 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3941             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3942 0         0 my @s = ($1,$2,$3);
3943 0         0 while (not /\G \z/oxgc) {
3944 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3945             # $1 $2 $3 $4
3946 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955             }
3956 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3957             }
3958             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3959 0         0 my @s = ($1,$2,$3);
3960 0         0 while (not /\G \z/oxgc) {
3961 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3962             # $1 $2 $3 $4
3963 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972             }
3973 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3974             }
3975             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3976 0         0 my @s = ($1,$2,$3);
3977 0         0 while (not /\G \z/oxgc) {
3978 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3979             # $1 $2 $3 $4
3980 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3985 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3986 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3987             }
3988 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3989             }
3990             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3991 0         0 my @s = ($1,$2,$3);
3992 0         0 while (not /\G \z/oxgc) {
3993 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3994             # $1 $2 $3 $4
3995 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3997 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3998 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3999 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4000 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4001 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4002 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4003 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4004             }
4005 0         0 die __FILE__, ": Substitution replacement not terminated\n";
4006             }
4007             # $1 $2 $3 $4 $5 $6
4008             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4009 21         51 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4010             }
4011             # $1 $2 $3 $4 $5 $6
4012             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4013 0         0 return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4014             }
4015             # $1 $2 $3 $4 $5 $6
4016             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4017 0         0 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4018             }
4019             # $1 $2 $3 $4 $5 $6
4020             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4021 75         235 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4022             }
4023             }
4024 0         0 die __FILE__, ": Substitution pattern not terminated\n";
4025             }
4026             }
4027              
4028             # require ignore module
4029 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4030 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4031 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4032              
4033             # use strict; --> use strict; no strict qw(refs);
4034 36         267 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4035 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4036 0         0 elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4037              
4038             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4039             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4040 2 50 33     23 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4041 0         0 return "use $1; no strict qw(refs);";
4042             }
4043             else {
4044 2         10 return "use $1;";
4045             }
4046             }
4047             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4048 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4049 0         0 return "use $1; no strict qw(refs);";
4050             }
4051             else {
4052 0         0 return "use $1;";
4053             }
4054             }
4055              
4056             # ignore use module
4057 2         11 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4058 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4059 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4060              
4061             # ignore no module
4062 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4063 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4064 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4065              
4066             # use else
4067 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4068              
4069             # use else
4070 2         5 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4071              
4072             # ''
4073             elsif (/\G (?
4074 841         1018 my $q_string = '';
4075 841         1799 while (not /\G \z/oxgc) {
4076 8222 100       23772 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       10  
    100          
    50          
4077 48         72 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4078 841         1547 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4079 7329         12135 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4080             }
4081 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4082             }
4083              
4084             # ""
4085             elsif (/\G (\") /oxgc) {
4086 1789         2207 my $qq_string = '';
4087 1789         3616 while (not /\G \z/oxgc) {
4088 34723 100       88979 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       131  
    100          
    50          
4089 12         30 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4090 1789         3099 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4091 32855         50936 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4092             }
4093 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4094             }
4095              
4096             # ``
4097             elsif (/\G (\`) /oxgc) {
4098 1         2 my $qx_string = '';
4099 1         5 while (not /\G \z/oxgc) {
4100 19 50       75 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4101 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4102 1         2 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4103 18         27 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4104             }
4105 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4106             }
4107              
4108             # // --- not divide operator (num / num), not defined-or
4109             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4110 452         601 my $regexp = '';
4111 452         977 while (not /\G \z/oxgc) {
4112 4490 50       13681 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4113 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4114 452         979 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4115 4038         6577 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4116             }
4117 0         0 die __FILE__, ": Search pattern not terminated\n";
4118             }
4119              
4120             # ?? --- not conditional operator (condition ? then : else)
4121             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4122 0         0 my $regexp = '';
4123 0         0 while (not /\G \z/oxgc) {
4124 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4125 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4126 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4127 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4128             }
4129 0         0 die __FILE__, ": Search pattern not terminated\n";
4130             }
4131              
4132             # <<>> (a safer ARGV)
4133 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4134              
4135             # << (bit shift) --- not here document
4136 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4137              
4138             # <<'HEREDOC'
4139             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4140 72         80 $slash = 'm//';
4141 72         105 my $here_quote = $1;
4142 72         83 my $delimiter = $2;
4143              
4144             # get here document
4145 72 50       113 if ($here_script eq '') {
4146 72         300 $here_script = CORE::substr $_, pos $_;
4147 72         332 $here_script =~ s/.*?\n//oxm;
4148             }
4149 72 50       493 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4150 72         179 push @heredoc, $1 . qq{\n$delimiter\n};
4151 72         87 push @heredoc_delimiter, $delimiter;
4152             }
4153             else {
4154 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4155             }
4156 72         240 return $here_quote;
4157             }
4158              
4159             # <<\HEREDOC
4160              
4161             # P.66 2.6.6. "Here" Documents
4162             # in Chapter 2: Bits and Pieces
4163             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4164              
4165             # P.73 "Here" Documents
4166             # in Chapter 2: Bits and Pieces
4167             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4168              
4169             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4170 0         0 $slash = 'm//';
4171 0         0 my $here_quote = $1;
4172 0         0 my $delimiter = $2;
4173              
4174             # get here document
4175 0 0       0 if ($here_script eq '') {
4176 0         0 $here_script = CORE::substr $_, pos $_;
4177 0         0 $here_script =~ s/.*?\n//oxm;
4178             }
4179 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4180 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4181 0         0 push @heredoc_delimiter, $delimiter;
4182             }
4183             else {
4184 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4185             }
4186 0         0 return $here_quote;
4187             }
4188              
4189             # <<"HEREDOC"
4190             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4191 36         54 $slash = 'm//';
4192 36         64 my $here_quote = $1;
4193 36         458 my $delimiter = $2;
4194              
4195             # get here document
4196 36 50       82 if ($here_script eq '') {
4197 36         211 $here_script = CORE::substr $_, pos $_;
4198 36         175 $here_script =~ s/.*?\n//oxm;
4199             }
4200 36 50       619 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4201 36         85 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4202 36         104 push @heredoc_delimiter, $delimiter;
4203             }
4204             else {
4205 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4206             }
4207 36         131 return $here_quote;
4208             }
4209              
4210             # <
4211             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4212 42         64 $slash = 'm//';
4213 42         67 my $here_quote = $1;
4214 42         55 my $delimiter = $2;
4215              
4216             # get here document
4217 42 50       90 if ($here_script eq '') {
4218 42         258 $here_script = CORE::substr $_, pos $_;
4219 42         260 $here_script =~ s/.*?\n//oxm;
4220             }
4221 42 50       547 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4222 42         113 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4223 42         71 push @heredoc_delimiter, $delimiter;
4224             }
4225             else {
4226 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4227             }
4228 42         168 return $here_quote;
4229             }
4230              
4231             # <<`HEREDOC`
4232             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4233 0         0 $slash = 'm//';
4234 0         0 my $here_quote = $1;
4235 0         0 my $delimiter = $2;
4236              
4237             # get here document
4238 0 0       0 if ($here_script eq '') {
4239 0         0 $here_script = CORE::substr $_, pos $_;
4240 0         0 $here_script =~ s/.*?\n//oxm;
4241             }
4242 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4243 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4244 0         0 push @heredoc_delimiter, $delimiter;
4245             }
4246             else {
4247 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4248             }
4249 0         0 return $here_quote;
4250             }
4251              
4252             # <<= <=> <= < operator
4253             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4254 11         48 return $1;
4255             }
4256              
4257             #
4258             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4259 0         0 return $1;
4260             }
4261              
4262             # --- glob
4263              
4264             # avoid "Error: Runtime exception" of perl version 5.005_03
4265              
4266             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4267 0         0 return 'Elatin10::glob("' . $1 . '")';
4268             }
4269              
4270             # __DATA__
4271 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4272              
4273             # __END__
4274 200         1122 elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4275              
4276             # \cD Control-D
4277              
4278             # P.68 2.6.8. Other Literal Tokens
4279             # in Chapter 2: Bits and Pieces
4280             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4281              
4282             # P.76 Other Literal Tokens
4283             # in Chapter 2: Bits and Pieces
4284             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4285              
4286 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4287              
4288             # \cZ Control-Z
4289 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4290              
4291             # any operator before div
4292             elsif (/\G (
4293             -- | \+\+ |
4294             [\)\}\]]
4295              
4296 4824         5128 ) /oxgc) { $slash = 'div'; return $1; }
  4824         16435  
4297              
4298             # yada-yada or triple-dot operator
4299             elsif (/\G (
4300             \.\.\.
4301              
4302 7         11 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         20  
4303              
4304             # any operator before m//
4305              
4306             # //, //= (defined-or)
4307              
4308             # P.164 Logical Operators
4309             # in Chapter 10: More Control Structures
4310             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4311              
4312             # P.119 C-Style Logical (Short-Circuit) Operators
4313             # in Chapter 3: Unary and Binary Operators
4314             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4315              
4316             # (and so on)
4317              
4318             # ~~
4319              
4320             # P.221 The Smart Match Operator
4321             # in Chapter 15: Smart Matching and given-when
4322             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4323              
4324             # P.112 Smartmatch Operator
4325             # in Chapter 3: Unary and Binary Operators
4326             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4327              
4328             # (and so on)
4329              
4330             elsif (/\G ((?>
4331              
4332             !~~ | !~ | != | ! |
4333             %= | % |
4334             &&= | && | &= | &\.= | &\. | & |
4335             -= | -> | - |
4336             :(?>\s*)= |
4337             : |
4338             <<>> |
4339             <<= | <=> | <= | < |
4340             == | => | =~ | = |
4341             >>= | >> | >= | > |
4342             \*\*= | \*\* | \*= | \* |
4343             \+= | \+ |
4344             \.\. | \.= | \. |
4345             \/\/= | \/\/ |
4346             \/= | \/ |
4347             \? |
4348             \\ |
4349             \^= | \^\.= | \^\. | \^ |
4350             \b x= |
4351             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4352             ~~ | ~\. | ~ |
4353             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4354             \b(?: print )\b |
4355              
4356             [,;\(\{\[]
4357              
4358 8506         8558 )) /oxgc) { $slash = 'm//'; return $1; }
  8506         28119  
4359              
4360             # other any character
4361 14864         13812 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14864         49474  
4362              
4363             # system error
4364             else {
4365 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4366             }
4367             }
4368              
4369             # escape Latin-10 string
4370             sub e_string {
4371 1718     1718 0 2687 my($string) = @_;
4372 1718         1574 my $e_string = '';
4373              
4374 1718         1693 local $slash = 'm//';
4375              
4376             # P.1024 Appendix W.10 Multibyte Processing
4377             # of ISBN 1-56592-224-7 CJKV Information Processing
4378             # (and so on)
4379              
4380 1718         12700 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4381              
4382             # without { ... }
4383 1718 100 66     6347 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4384 1701 50       2863 if ($string !~ /<
4385 1701         3293 return $string;
4386             }
4387             }
4388              
4389             E_STRING_LOOP:
4390 17         47 while ($string !~ /\G \z/oxgc) {
4391 190 50       11960 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          
4392             }
4393              
4394             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin10::PREMATCH()]}
4395 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4396 0         0 $e_string .= q{Elatin10::PREMATCH()};
4397 0         0 $slash = 'div';
4398             }
4399              
4400             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin10::MATCH()]}
4401             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4402 0         0 $e_string .= q{Elatin10::MATCH()};
4403 0         0 $slash = 'div';
4404             }
4405              
4406             # $', ${'} --> $', ${'}
4407             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4408 0         0 $e_string .= $1;
4409 0         0 $slash = 'div';
4410             }
4411              
4412             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin10::POSTMATCH()]}
4413             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4414 0         0 $e_string .= q{Elatin10::POSTMATCH()};
4415 0         0 $slash = 'div';
4416             }
4417              
4418             # bareword
4419             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4420 0         0 $e_string .= $1;
4421 0         0 $slash = 'div';
4422             }
4423              
4424             # $0 --> $0
4425             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4426 0         0 $e_string .= $1;
4427 0         0 $slash = 'div';
4428             }
4429             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4430 0         0 $e_string .= $1;
4431 0         0 $slash = 'div';
4432             }
4433              
4434             # $$ --> $$
4435             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4436 0         0 $e_string .= $1;
4437 0         0 $slash = 'div';
4438             }
4439              
4440             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4441             # $1, $2, $3 --> $1, $2, $3 otherwise
4442             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4443 0         0 $e_string .= e_capture($1);
4444 0         0 $slash = 'div';
4445             }
4446             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4447 0         0 $e_string .= e_capture($1);
4448 0         0 $slash = 'div';
4449             }
4450              
4451             # $$foo[ ... ] --> $ $foo->[ ... ]
4452             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4453 0         0 $e_string .= e_capture($1.'->'.$2);
4454 0         0 $slash = 'div';
4455             }
4456              
4457             # $$foo{ ... } --> $ $foo->{ ... }
4458             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4459 0         0 $e_string .= e_capture($1.'->'.$2);
4460 0         0 $slash = 'div';
4461             }
4462              
4463             # $$foo
4464             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4465 0         0 $e_string .= e_capture($1);
4466 0         0 $slash = 'div';
4467             }
4468              
4469             # ${ foo }
4470             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4471 0         0 $e_string .= '${' . $1 . '}';
4472 0         0 $slash = 'div';
4473             }
4474              
4475             # ${ ... }
4476             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4477 3         8 $e_string .= e_capture($1);
4478 3         14 $slash = 'div';
4479             }
4480              
4481             # variable or function
4482             # $ @ % & * $ #
4483             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) {
4484 7         14 $e_string .= $1;
4485 7         22 $slash = 'div';
4486             }
4487             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4488             # $ @ # \ ' " / ? ( ) [ ] < >
4489             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4490 0         0 $e_string .= $1;
4491 0         0 $slash = 'div';
4492             }
4493              
4494             # subroutines of package Elatin10
4495 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4496 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4497 0         0 elsif ($string =~ /\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4498 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4499 0         0 elsif ($string =~ /\G \b Latin10::eval \b /oxgc) { $e_string .= 'eval Latin10::escape'; $slash = 'm//'; }
  0         0  
4500 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4501 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin10::chop'; $slash = 'm//'; }
  0         0  
4502 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4503 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4504 0         0 elsif ($string =~ /\G \b Latin10::index \b /oxgc) { $e_string .= 'Latin10::index'; $slash = 'm//'; }
  0         0  
4505 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin10::index'; $slash = 'm//'; }
  0         0  
4506 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4507 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4508 0         0 elsif ($string =~ /\G \b Latin10::rindex \b /oxgc) { $e_string .= 'Latin10::rindex'; $slash = 'm//'; }
  0         0  
4509 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin10::rindex'; $slash = 'm//'; }
  0         0  
4510 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lc'; $slash = 'm//'; }
  0         0  
4511 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::lcfirst'; $slash = 'm//'; }
  0         0  
4512 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::uc'; $slash = 'm//'; }
  0         0  
4513 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::ucfirst'; $slash = 'm//'; }
  0         0  
4514 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::fc'; $slash = 'm//'; }
  0         0  
4515              
4516             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4517 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4518 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  
4519 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  
4520 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  
4521 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  
4522 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  
4523 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  
4524              
4525 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4526 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  
4527 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  
4528 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  
4529 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  
4530 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  
4531 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  
4532              
4533             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4534 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4535 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4536 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4537 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4538              
4539 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4540 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4541 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::chr'; $slash = 'm//'; }
  0         0  
4542 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4543 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4544 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin10::glob'; $slash = 'm//'; }
  0         0  
4545 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin10::lc_'; $slash = 'm//'; }
  0         0  
4546 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin10::lcfirst_'; $slash = 'm//'; }
  0         0  
4547 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin10::uc_'; $slash = 'm//'; }
  0         0  
4548 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin10::ucfirst_'; $slash = 'm//'; }
  0         0  
4549 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin10::fc_'; $slash = 'm//'; }
  0         0  
4550 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4551              
4552 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4553 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4554 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin10::chr_'; $slash = 'm//'; }
  0         0  
4555 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4556 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4557 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin10::glob_'; $slash = 'm//'; }
  0         0  
4558 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4559 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4560             # split
4561             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4562 0         0 $slash = 'm//';
4563              
4564 0         0 my $e = '';
4565 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4566 0         0 $e .= $1;
4567             }
4568              
4569             # end of split
4570 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::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          
4571              
4572             # split scalar value
4573 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin10::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4574              
4575             # split literal space
4576 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4577 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4578 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4579 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4580 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4581 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4582 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4583 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4584 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4585 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4586 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4587 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4588 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4589 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin10::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4590              
4591             # split qq//
4592             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4593 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  
4594             else {
4595 0         0 while ($string !~ /\G \z/oxgc) {
4596 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4597 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  
4598 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  
4599 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  
4600 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  
4601 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4602 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  
4603             }
4604 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4605             }
4606             }
4607              
4608             # split qr//
4609             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4610 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  
4611             else {
4612 0         0 while ($string !~ /\G \z/oxgc) {
4613 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4614 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  
4615 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  
4616 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  
4617 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  
4618 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  
4619 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  
4620 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  
4621             }
4622 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4623             }
4624             }
4625              
4626             # split q//
4627             elsif ($string =~ /\G \b (q) \b /oxgc) {
4628 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  
4629             else {
4630 0         0 while ($string !~ /\G \z/oxgc) {
4631 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4632 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  
4633 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  
4634 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  
4635 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  
4636 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  
4637 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  
4638             }
4639 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4640             }
4641             }
4642              
4643             # split m//
4644             elsif ($string =~ /\G \b (m) \b /oxgc) {
4645 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  
4646             else {
4647 0         0 while ($string !~ /\G \z/oxgc) {
4648 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4649 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  
4650 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  
4651 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  
4652 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  
4653 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  
4654 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  
4655 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  
4656             }
4657 0         0 die __FILE__, ": Search pattern not terminated\n";
4658             }
4659             }
4660              
4661             # split ''
4662             elsif ($string =~ /\G (\') /oxgc) {
4663 0         0 my $q_string = '';
4664 0         0 while ($string !~ /\G \z/oxgc) {
4665 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4666 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4667 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4668 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4669             }
4670 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4671             }
4672              
4673             # split ""
4674             elsif ($string =~ /\G (\") /oxgc) {
4675 0         0 my $qq_string = '';
4676 0         0 while ($string !~ /\G \z/oxgc) {
4677 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4678 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4679 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4680 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4681             }
4682 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4683             }
4684              
4685             # split //
4686             elsif ($string =~ /\G (\/) /oxgc) {
4687 0         0 my $regexp = '';
4688 0         0 while ($string !~ /\G \z/oxgc) {
4689 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4690 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4691 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4692 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4693             }
4694 0         0 die __FILE__, ": Search pattern not terminated\n";
4695             }
4696             }
4697              
4698             # qq//
4699             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4700 0         0 my $ope = $1;
4701 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4702 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4703             }
4704             else {
4705 0         0 my $e = '';
4706 0         0 while ($string !~ /\G \z/oxgc) {
4707 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4708 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4709 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4710 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4711 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  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; } # qq * *
  0         0  
4713             }
4714 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4715             }
4716             }
4717              
4718             # qx//
4719             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4720 0         0 my $ope = $1;
4721 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4722 0         0 $e_string .= e_qq($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          
    0          
4728 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4729 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4730 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4731 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4732 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4733 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  
4734             }
4735 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4736             }
4737             }
4738              
4739             # q//
4740             elsif ($string =~ /\G \b (q) \b /oxgc) {
4741 0         0 my $ope = $1;
4742 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4743 0         0 $e_string .= e_q($ope,$1,$3,$2);
4744             }
4745             else {
4746 0         0 my $e = '';
4747 0         0 while ($string !~ /\G \z/oxgc) {
4748 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4749 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4750 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4751 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4752 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4753 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  
4754             }
4755 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4756             }
4757             }
4758              
4759             # ''
4760 0         0 elsif ($string =~ /\G (?
4761              
4762             # ""
4763 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4764              
4765             # ``
4766 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4767              
4768             # <<>> (a safer ARGV)
4769 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4770              
4771             # <<= <=> <= < operator
4772 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4773              
4774             #
4775 0         0 elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4776              
4777             # --- glob
4778             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4779 0         0 $e_string .= 'Elatin10::glob("' . $1 . '")';
4780             }
4781              
4782             # << (bit shift) --- not here document
4783 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
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, $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             # <<"HEREDOC"
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             # <
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             # <<`HEREDOC`
4870             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4871 0         0 $slash = 'm//';
4872 0         0 my $here_quote = $1;
4873 0         0 my $delimiter = $2;
4874              
4875             # get here document
4876 0 0       0 if ($here_script eq '') {
4877 0         0 $here_script = CORE::substr $_, pos $_;
4878 0         0 $here_script =~ s/.*?\n//oxm;
4879             }
4880 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4881 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4882 0         0 push @heredoc_delimiter, $delimiter;
4883             }
4884             else {
4885 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4886             }
4887 0         0 $e_string .= $here_quote;
4888             }
4889              
4890             # any operator before div
4891             elsif ($string =~ /\G (
4892             -- | \+\+ |
4893             [\)\}\]]
4894              
4895 18         37 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         48  
4896              
4897             # yada-yada or triple-dot operator
4898             elsif ($string =~ /\G (
4899             \.\.\.
4900              
4901 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         0  
4902              
4903             # any operator before m//
4904             elsif ($string =~ /\G ((?>
4905              
4906             !~~ | !~ | != | ! |
4907             %= | % |
4908             &&= | && | &= | &\.= | &\. | & |
4909             -= | -> | - |
4910             :(?>\s*)= |
4911             : |
4912             <<>> |
4913             <<= | <=> | <= | < |
4914             == | => | =~ | = |
4915             >>= | >> | >= | > |
4916             \*\*= | \*\* | \*= | \* |
4917             \+= | \+ |
4918             \.\. | \.= | \. |
4919             \/\/= | \/\/ |
4920             \/= | \/ |
4921             \? |
4922             \\ |
4923             \^= | \^\.= | \^\. | \^ |
4924             \b x= |
4925             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4926             ~~ | ~\. | ~ |
4927             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4928             \b(?: print )\b |
4929              
4930             [,;\(\{\[]
4931              
4932 31         35 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         107  
4933              
4934             # other any character
4935 131         301 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4936              
4937             # system error
4938             else {
4939 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4940             }
4941             }
4942              
4943 17         55 return $e_string;
4944             }
4945              
4946             #
4947             # character class
4948             #
4949             sub character_class {
4950 1914     1914 0 1940 my($char,$modifier) = @_;
4951              
4952 1914 100       2227 if ($char eq '.') {
4953 52 100       86 if ($modifier =~ /s/) {
4954 17         36 return '${Elatin10::dot_s}';
4955             }
4956             else {
4957 35         57 return '${Elatin10::dot}';
4958             }
4959             }
4960             else {
4961 1862         2329 return Elatin10::classic_character_class($char);
4962             }
4963             }
4964              
4965             #
4966             # escape capture ($1, $2, $3, ...)
4967             #
4968             sub e_capture {
4969              
4970 212     212 0 674 return join '', '${', $_[0], '}';
4971             }
4972              
4973             #
4974             # escape transliteration (tr/// or y///)
4975             #
4976             sub e_tr {
4977 3     3 0 7 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4978 3         2 my $e_tr = '';
4979 3   50     6 $modifier ||= '';
4980              
4981 3         1 $slash = 'div';
4982              
4983             # quote character class 1
4984 3         6 $charclass = q_tr($charclass);
4985              
4986             # quote character class 2
4987 3         3 $charclass2 = q_tr($charclass2);
4988              
4989             # /b /B modifier
4990 3 50       10 if ($modifier =~ tr/bB//d) {
4991 0 0       0 if ($variable eq '') {
4992 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4993             }
4994             else {
4995 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4996             }
4997             }
4998             else {
4999 3 100       4 if ($variable eq '') {
5000 2         4 $e_tr = qq{Elatin10::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5001             }
5002             else {
5003 1         4 $e_tr = qq{Elatin10::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5004             }
5005             }
5006              
5007             # clear tr/// variable
5008 3         2 $tr_variable = '';
5009 3         3 $bind_operator = '';
5010              
5011 3         12 return $e_tr;
5012             }
5013              
5014             #
5015             # quote for escape transliteration (tr/// or y///)
5016             #
5017             sub q_tr {
5018 6     6 0 4 my($charclass) = @_;
5019              
5020             # quote character class
5021 6 50       10 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5022 6         6 return e_q('', "'", "'", $charclass); # --> q' '
5023             }
5024             elsif ($charclass !~ /\//oxms) {
5025 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
5026             }
5027             elsif ($charclass !~ /\#/oxms) {
5028 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
5029             }
5030             elsif ($charclass !~ /[\<\>]/oxms) {
5031 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
5032             }
5033             elsif ($charclass !~ /[\(\)]/oxms) {
5034 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
5035             }
5036             elsif ($charclass !~ /[\{\}]/oxms) {
5037 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5038             }
5039             else {
5040 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5041 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5042 0         0 return e_q('q', $char, $char, $charclass);
5043             }
5044             }
5045             }
5046              
5047 0         0 return e_q('q', '{', '}', $charclass);
5048             }
5049              
5050             #
5051             # escape q string (q//, '')
5052             #
5053             sub e_q {
5054 1092     1092 0 1695 my($ope,$delimiter,$end_delimiter,$string) = @_;
5055              
5056 1092         1018 $slash = 'div';
5057              
5058 1092         4739 return join '', $ope, $delimiter, $string, $end_delimiter;
5059             }
5060              
5061             #
5062             # escape qq string (qq//, "", qx//, ``)
5063             #
5064             sub e_qq {
5065 4001     4001 0 5747 my($ope,$delimiter,$end_delimiter,$string) = @_;
5066              
5067 4001         3648 $slash = 'div';
5068              
5069 4001         3194 my $left_e = 0;
5070 4001         2743 my $right_e = 0;
5071              
5072             # split regexp
5073 4001         117860 my @char = $string =~ /\G((?>
5074             [^\\\$] |
5075             \\x\{ (?>[0-9A-Fa-f]+) \} |
5076             \\o\{ (?>[0-7]+) \} |
5077             \\N\{ (?>[^0-9\}][^\}]*) \} |
5078             \\ $q_char |
5079             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5080             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5081             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5082             \$ (?>\s* [0-9]+) |
5083             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5084             \$ \$ (?![\w\{]) |
5085             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5086             $q_char
5087             ))/oxmsg;
5088              
5089 4001         12350 for (my $i=0; $i <= $#char; $i++) {
5090              
5091             # "\L\u" --> "\u\L"
5092 112180 50 33     396654 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5093 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5094             }
5095              
5096             # "\U\l" --> "\l\U"
5097             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5098 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5099             }
5100              
5101             # octal escape sequence
5102             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5103 1         7 $char[$i] = Elatin10::octchr($1);
5104             }
5105              
5106             # hexadecimal escape sequence
5107             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5108 1         3 $char[$i] = Elatin10::hexchr($1);
5109             }
5110              
5111             # \N{CHARNAME} --> N{CHARNAME}
5112             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5113 0         0 $char[$i] = $1;
5114             }
5115              
5116 112180 100       1063517 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5117             }
5118              
5119             # \F
5120             #
5121             # P.69 Table 2-6. Translation escapes
5122             # in Chapter 2: Bits and Pieces
5123             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5124             # (and so on)
5125              
5126             # \u \l \U \L \F \Q \E
5127 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5128 484 50       1061 if ($right_e < $left_e) {
5129 0         0 $char[$i] = '\\' . $char[$i];
5130             }
5131             }
5132             elsif ($char[$i] eq '\u') {
5133              
5134             # "STRING @{[ LIST EXPR ]} MORE STRING"
5135              
5136             # P.257 Other Tricks You Can Do with Hard References
5137             # in Chapter 8: References
5138             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5139              
5140             # P.353 Other Tricks You Can Do with Hard References
5141             # in Chapter 8: References
5142             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5143              
5144             # (and so on)
5145              
5146 0         0 $char[$i] = '@{[Elatin10::ucfirst qq<';
5147 0         0 $left_e++;
5148             }
5149             elsif ($char[$i] eq '\l') {
5150 0         0 $char[$i] = '@{[Elatin10::lcfirst qq<';
5151 0         0 $left_e++;
5152             }
5153             elsif ($char[$i] eq '\U') {
5154 0         0 $char[$i] = '@{[Elatin10::uc qq<';
5155 0         0 $left_e++;
5156             }
5157             elsif ($char[$i] eq '\L') {
5158 0         0 $char[$i] = '@{[Elatin10::lc qq<';
5159 0         0 $left_e++;
5160             }
5161             elsif ($char[$i] eq '\F') {
5162 24         20 $char[$i] = '@{[Elatin10::fc qq<';
5163 24         42 $left_e++;
5164             }
5165             elsif ($char[$i] eq '\Q') {
5166 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5167 0         0 $left_e++;
5168             }
5169             elsif ($char[$i] eq '\E') {
5170 24 50       26 if ($right_e < $left_e) {
5171 24         24 $char[$i] = '>]}';
5172 24         32 $right_e++;
5173             }
5174             else {
5175 0         0 $char[$i] = '';
5176             }
5177             }
5178             elsif ($char[$i] eq '\Q') {
5179 0         0 while (1) {
5180 0 0       0 if (++$i > $#char) {
5181 0         0 last;
5182             }
5183 0 0       0 if ($char[$i] eq '\E') {
5184 0         0 last;
5185             }
5186             }
5187             }
5188             elsif ($char[$i] eq '\E') {
5189             }
5190              
5191             # $0 --> $0
5192             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5193             }
5194             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5195             }
5196              
5197             # $$ --> $$
5198             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5199             }
5200              
5201             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5202             # $1, $2, $3 --> $1, $2, $3 otherwise
5203             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5204 205         298 $char[$i] = e_capture($1);
5205             }
5206             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5207 0         0 $char[$i] = e_capture($1);
5208             }
5209              
5210             # $$foo[ ... ] --> $ $foo->[ ... ]
5211             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5212 0         0 $char[$i] = e_capture($1.'->'.$2);
5213             }
5214              
5215             # $$foo{ ... } --> $ $foo->{ ... }
5216             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5217 0         0 $char[$i] = e_capture($1.'->'.$2);
5218             }
5219              
5220             # $$foo
5221             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5222 0         0 $char[$i] = e_capture($1);
5223             }
5224              
5225             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5226             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5227 44         124 $char[$i] = '@{[Elatin10::PREMATCH()]}';
5228             }
5229              
5230             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5231             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5232 45         100 $char[$i] = '@{[Elatin10::MATCH()]}';
5233             }
5234              
5235             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5236             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5237 33         74 $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5238             }
5239              
5240             # ${ foo } --> ${ foo }
5241             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5242             }
5243              
5244             # ${ ... }
5245             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5246 0         0 $char[$i] = e_capture($1);
5247             }
5248             }
5249              
5250             # return string
5251 4001 50       6102 if ($left_e > $right_e) {
5252 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5253             }
5254 4001         28628 return join '', $ope, $delimiter, @char, $end_delimiter;
5255             }
5256              
5257             #
5258             # escape qw string (qw//)
5259             #
5260             sub e_qw {
5261 16     16 0 83 my($ope,$delimiter,$end_delimiter,$string) = @_;
5262              
5263 16         21 $slash = 'div';
5264              
5265             # choice again delimiter
5266 16         176 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         492  
5267 16 50       83 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5268 16         114 return join '', $ope, $delimiter, $string, $end_delimiter;
5269             }
5270             elsif (not $octet{')'}) {
5271 0         0 return join '', $ope, '(', $string, ')';
5272             }
5273             elsif (not $octet{'}'}) {
5274 0         0 return join '', $ope, '{', $string, '}';
5275             }
5276             elsif (not $octet{']'}) {
5277 0         0 return join '', $ope, '[', $string, ']';
5278             }
5279             elsif (not $octet{'>'}) {
5280 0         0 return join '', $ope, '<', $string, '>';
5281             }
5282             else {
5283 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5284 0 0       0 if (not $octet{$char}) {
5285 0         0 return join '', $ope, $char, $string, $char;
5286             }
5287             }
5288             }
5289              
5290             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5291 0         0 my @string = CORE::split(/\s+/, $string);
5292 0         0 for my $string (@string) {
5293 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5294 0         0 for my $octet (@octet) {
5295 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5296 0         0 $octet = '\\' . $1;
5297             }
5298             }
5299 0         0 $string = join '', @octet;
5300             }
5301 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5302             }
5303              
5304             #
5305             # escape here document (<<"HEREDOC", <
5306             #
5307             sub e_heredoc {
5308 78     78 0 137 my($string) = @_;
5309              
5310 78         90 $slash = 'm//';
5311              
5312 78         221 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5313              
5314 78         84 my $left_e = 0;
5315 78         63 my $right_e = 0;
5316              
5317             # split regexp
5318 78         6415 my @char = $string =~ /\G((?>
5319             [^\\\$] |
5320             \\x\{ (?>[0-9A-Fa-f]+) \} |
5321             \\o\{ (?>[0-7]+) \} |
5322             \\N\{ (?>[^0-9\}][^\}]*) \} |
5323             \\ $q_char |
5324             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5325             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5326             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5327             \$ (?>\s* [0-9]+) |
5328             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5329             \$ \$ (?![\w\{]) |
5330             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5331             $q_char
5332             ))/oxmsg;
5333              
5334 78         354 for (my $i=0; $i <= $#char; $i++) {
5335              
5336             # "\L\u" --> "\u\L"
5337 2908 50 33     10027 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5338 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5339             }
5340              
5341             # "\U\l" --> "\l\U"
5342             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5343 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5344             }
5345              
5346             # octal escape sequence
5347             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5348 1         3 $char[$i] = Elatin10::octchr($1);
5349             }
5350              
5351             # hexadecimal escape sequence
5352             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5353 1         3 $char[$i] = Elatin10::hexchr($1);
5354             }
5355              
5356             # \N{CHARNAME} --> N{CHARNAME}
5357             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5358 0         0 $char[$i] = $1;
5359             }
5360              
5361 2908 50       28512 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5362             }
5363              
5364             # \u \l \U \L \F \Q \E
5365 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5366 0 0       0 if ($right_e < $left_e) {
5367 0         0 $char[$i] = '\\' . $char[$i];
5368             }
5369             }
5370             elsif ($char[$i] eq '\u') {
5371 0         0 $char[$i] = '@{[Elatin10::ucfirst qq<';
5372 0         0 $left_e++;
5373             }
5374             elsif ($char[$i] eq '\l') {
5375 0         0 $char[$i] = '@{[Elatin10::lcfirst qq<';
5376 0         0 $left_e++;
5377             }
5378             elsif ($char[$i] eq '\U') {
5379 0         0 $char[$i] = '@{[Elatin10::uc qq<';
5380 0         0 $left_e++;
5381             }
5382             elsif ($char[$i] eq '\L') {
5383 0         0 $char[$i] = '@{[Elatin10::lc qq<';
5384 0         0 $left_e++;
5385             }
5386             elsif ($char[$i] eq '\F') {
5387 0         0 $char[$i] = '@{[Elatin10::fc qq<';
5388 0         0 $left_e++;
5389             }
5390             elsif ($char[$i] eq '\Q') {
5391 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5392 0         0 $left_e++;
5393             }
5394             elsif ($char[$i] eq '\E') {
5395 0 0       0 if ($right_e < $left_e) {
5396 0         0 $char[$i] = '>]}';
5397 0         0 $right_e++;
5398             }
5399             else {
5400 0         0 $char[$i] = '';
5401             }
5402             }
5403             elsif ($char[$i] eq '\Q') {
5404 0         0 while (1) {
5405 0 0       0 if (++$i > $#char) {
5406 0         0 last;
5407             }
5408 0 0       0 if ($char[$i] eq '\E') {
5409 0         0 last;
5410             }
5411             }
5412             }
5413             elsif ($char[$i] eq '\E') {
5414             }
5415              
5416             # $0 --> $0
5417             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5418             }
5419             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5420             }
5421              
5422             # $$ --> $$
5423             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5424             }
5425              
5426             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5427             # $1, $2, $3 --> $1, $2, $3 otherwise
5428             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5429 0         0 $char[$i] = e_capture($1);
5430             }
5431             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5432 0         0 $char[$i] = e_capture($1);
5433             }
5434              
5435             # $$foo[ ... ] --> $ $foo->[ ... ]
5436             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5437 0         0 $char[$i] = e_capture($1.'->'.$2);
5438             }
5439              
5440             # $$foo{ ... } --> $ $foo->{ ... }
5441             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5442 0         0 $char[$i] = e_capture($1.'->'.$2);
5443             }
5444              
5445             # $$foo
5446             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5447 0         0 $char[$i] = e_capture($1);
5448             }
5449              
5450             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5451             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5452 8         39 $char[$i] = '@{[Elatin10::PREMATCH()]}';
5453             }
5454              
5455             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5456             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5457 8         33 $char[$i] = '@{[Elatin10::MATCH()]}';
5458             }
5459              
5460             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5461             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5462 6         25 $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5463             }
5464              
5465             # ${ foo } --> ${ foo }
5466             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5467             }
5468              
5469             # ${ ... }
5470             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5471 0         0 $char[$i] = e_capture($1);
5472             }
5473             }
5474              
5475             # return string
5476 78 50       137 if ($left_e > $right_e) {
5477 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5478             }
5479 78         550 return join '', @char;
5480             }
5481              
5482             #
5483             # escape regexp (m//, qr//)
5484             #
5485             sub e_qr {
5486 651     651 0 1386 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5487 651   100     1805 $modifier ||= '';
5488              
5489 651         785 $modifier =~ tr/p//d;
5490 651 50       1246 if ($modifier =~ /([adlu])/oxms) {
5491 0         0 my $line = 0;
5492 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5493 0 0       0 if ($filename ne __FILE__) {
5494 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5495 0         0 last;
5496             }
5497             }
5498 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5499             }
5500              
5501 651         659 $slash = 'div';
5502              
5503             # literal null string pattern
5504 651 100       1613 if ($string eq '') {
    100          
5505 8         6 $modifier =~ tr/bB//d;
5506 8         7 $modifier =~ tr/i//d;
5507 8         36 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5508             }
5509              
5510             # /b /B modifier
5511             elsif ($modifier =~ tr/bB//d) {
5512              
5513             # choice again delimiter
5514 2 50       13 if ($delimiter =~ / [\@:] /oxms) {
5515 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5516 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5517 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5518 0         0 $delimiter = '(';
5519 0         0 $end_delimiter = ')';
5520             }
5521             elsif (not $octet{'}'}) {
5522 0         0 $delimiter = '{';
5523 0         0 $end_delimiter = '}';
5524             }
5525             elsif (not $octet{']'}) {
5526 0         0 $delimiter = '[';
5527 0         0 $end_delimiter = ']';
5528             }
5529             elsif (not $octet{'>'}) {
5530 0         0 $delimiter = '<';
5531 0         0 $end_delimiter = '>';
5532             }
5533             else {
5534 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5535 0 0       0 if (not $octet{$char}) {
5536 0         0 $delimiter = $char;
5537 0         0 $end_delimiter = $char;
5538 0         0 last;
5539             }
5540             }
5541             }
5542             }
5543              
5544 2 50 33     13 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5545 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5546             }
5547             else {
5548 2         10 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5549             }
5550             }
5551              
5552 641 100       1087 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5553 641         1831 my $metachar = qr/[\@\\|[\]{^]/oxms;
5554              
5555             # split regexp
5556 641         54483 my @char = $string =~ /\G((?>
5557             [^\\\$\@\[\(] |
5558             \\x (?>[0-9A-Fa-f]{1,2}) |
5559             \\ (?>[0-7]{2,3}) |
5560             \\c [\x40-\x5F] |
5561             \\x\{ (?>[0-9A-Fa-f]+) \} |
5562             \\o\{ (?>[0-7]+) \} |
5563             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5564             \\ $q_char |
5565             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5566             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5567             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5568             [\$\@] $qq_variable |
5569             \$ (?>\s* [0-9]+) |
5570             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5571             \$ \$ (?![\w\{]) |
5572             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5573             \[\^ |
5574             \[\: (?>[a-z]+) :\] |
5575             \[\:\^ (?>[a-z]+) :\] |
5576             \(\? |
5577             $q_char
5578             ))/oxmsg;
5579              
5580             # choice again delimiter
5581 641 50       2482 if ($delimiter =~ / [\@:] /oxms) {
5582 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5583 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5584 0         0 $delimiter = '(';
5585 0         0 $end_delimiter = ')';
5586             }
5587             elsif (not $octet{'}'}) {
5588 0         0 $delimiter = '{';
5589 0         0 $end_delimiter = '}';
5590             }
5591             elsif (not $octet{']'}) {
5592 0         0 $delimiter = '[';
5593 0         0 $end_delimiter = ']';
5594             }
5595             elsif (not $octet{'>'}) {
5596 0         0 $delimiter = '<';
5597 0         0 $end_delimiter = '>';
5598             }
5599             else {
5600 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5601 0 0       0 if (not $octet{$char}) {
5602 0         0 $delimiter = $char;
5603 0         0 $end_delimiter = $char;
5604 0         0 last;
5605             }
5606             }
5607             }
5608             }
5609              
5610 641         623 my $left_e = 0;
5611 641         520 my $right_e = 0;
5612 641         1329 for (my $i=0; $i <= $#char; $i++) {
5613              
5614             # "\L\u" --> "\u\L"
5615 1867 50 66     9503 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5616 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5617             }
5618              
5619             # "\U\l" --> "\l\U"
5620             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5621 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5622             }
5623              
5624             # octal escape sequence
5625             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5626 1         2 $char[$i] = Elatin10::octchr($1);
5627             }
5628              
5629             # hexadecimal escape sequence
5630             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5631 1         2 $char[$i] = Elatin10::hexchr($1);
5632             }
5633              
5634             # \b{...} --> b\{...}
5635             # \B{...} --> B\{...}
5636             # \N{CHARNAME} --> N\{CHARNAME}
5637             # \p{PROPERTY} --> p\{PROPERTY}
5638             # \P{PROPERTY} --> P\{PROPERTY}
5639             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5640 6         14 $char[$i] = $1 . '\\' . $2;
5641             }
5642              
5643             # \p, \P, \X --> p, P, X
5644             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5645 4         9 $char[$i] = $1;
5646             }
5647              
5648 1867 100 100     4754 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          
5649             }
5650              
5651             # join separated multiple-octet
5652 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5653 6 50 33     75 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        
5654 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
5655             }
5656             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)) {
5657 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
5658             }
5659             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)) {
5660 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
5661             }
5662             }
5663              
5664             # open character class [...]
5665             elsif ($char[$i] eq '[') {
5666 328         314 my $left = $i;
5667              
5668             # [] make die "Unmatched [] in regexp ...\n"
5669             # (and so on)
5670              
5671 328 100       700 if ($char[$i+1] eq ']') {
5672 3         5 $i++;
5673             }
5674              
5675 328         280 while (1) {
5676 1379 50       1675 if (++$i > $#char) {
5677 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5678             }
5679 1379 100       1812 if ($char[$i] eq ']') {
5680 328         251 my $right = $i;
5681              
5682             # [...]
5683 328 100       1415 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5684 30         46 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         111  
5685             }
5686             else {
5687 298         891 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5688             }
5689              
5690 328         382 $i = $left;
5691 328         766 last;
5692             }
5693             }
5694             }
5695              
5696             # open character class [^...]
5697             elsif ($char[$i] eq '[^') {
5698 74         67 my $left = $i;
5699              
5700             # [^] make die "Unmatched [] in regexp ...\n"
5701             # (and so on)
5702              
5703 74 100       164 if ($char[$i+1] eq ']') {
5704 4         5 $i++;
5705             }
5706              
5707 74         74 while (1) {
5708 272 50       339 if (++$i > $#char) {
5709 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5710             }
5711 272 100       406 if ($char[$i] eq ']') {
5712 74         105 my $right = $i;
5713              
5714             # [^...]
5715 74 100       355 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5716 30         55 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         108  
5717             }
5718             else {
5719 44         156 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5720             }
5721              
5722 74         94 $i = $left;
5723 74         183 last;
5724             }
5725             }
5726             }
5727              
5728             # rewrite character class or escape character
5729             elsif (my $char = character_class($char[$i],$modifier)) {
5730 139         448 $char[$i] = $char;
5731             }
5732              
5733             # /i modifier
5734             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
5735 20 50       22 if (CORE::length(Elatin10::fc($char[$i])) == 1) {
5736 20         21 $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
5737             }
5738             else {
5739 0         0 $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
5740             }
5741             }
5742              
5743             # \u \l \U \L \F \Q \E
5744             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5745 1 50       4 if ($right_e < $left_e) {
5746 0         0 $char[$i] = '\\' . $char[$i];
5747             }
5748             }
5749             elsif ($char[$i] eq '\u') {
5750 0         0 $char[$i] = '@{[Elatin10::ucfirst qq<';
5751 0         0 $left_e++;
5752             }
5753             elsif ($char[$i] eq '\l') {
5754 0         0 $char[$i] = '@{[Elatin10::lcfirst qq<';
5755 0         0 $left_e++;
5756             }
5757             elsif ($char[$i] eq '\U') {
5758 1         2 $char[$i] = '@{[Elatin10::uc qq<';
5759 1         5 $left_e++;
5760             }
5761             elsif ($char[$i] eq '\L') {
5762 1         2 $char[$i] = '@{[Elatin10::lc qq<';
5763 1         4 $left_e++;
5764             }
5765             elsif ($char[$i] eq '\F') {
5766 18         15 $char[$i] = '@{[Elatin10::fc qq<';
5767 18         67 $left_e++;
5768             }
5769             elsif ($char[$i] eq '\Q') {
5770 1         2 $char[$i] = '@{[CORE::quotemeta qq<';
5771 1         4 $left_e++;
5772             }
5773             elsif ($char[$i] eq '\E') {
5774 21 50       30 if ($right_e < $left_e) {
5775 21         16 $char[$i] = '>]}';
5776 21         63 $right_e++;
5777             }
5778             else {
5779 0         0 $char[$i] = '';
5780             }
5781             }
5782             elsif ($char[$i] eq '\Q') {
5783 0         0 while (1) {
5784 0 0       0 if (++$i > $#char) {
5785 0         0 last;
5786             }
5787 0 0       0 if ($char[$i] eq '\E') {
5788 0         0 last;
5789             }
5790             }
5791             }
5792             elsif ($char[$i] eq '\E') {
5793             }
5794              
5795             # $0 --> $0
5796             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5797 0 0       0 if ($ignorecase) {
5798 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5799             }
5800             }
5801             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5802 0 0       0 if ($ignorecase) {
5803 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5804             }
5805             }
5806              
5807             # $$ --> $$
5808             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5809             }
5810              
5811             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5812             # $1, $2, $3 --> $1, $2, $3 otherwise
5813             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5814 0         0 $char[$i] = e_capture($1);
5815 0 0       0 if ($ignorecase) {
5816 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5817             }
5818             }
5819             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5820 0         0 $char[$i] = e_capture($1);
5821 0 0       0 if ($ignorecase) {
5822 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5823             }
5824             }
5825              
5826             # $$foo[ ... ] --> $ $foo->[ ... ]
5827             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5828 0         0 $char[$i] = e_capture($1.'->'.$2);
5829 0 0       0 if ($ignorecase) {
5830 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5831             }
5832             }
5833              
5834             # $$foo{ ... } --> $ $foo->{ ... }
5835             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5836 0         0 $char[$i] = e_capture($1.'->'.$2);
5837 0 0       0 if ($ignorecase) {
5838 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5839             }
5840             }
5841              
5842             # $$foo
5843             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5844 0         0 $char[$i] = e_capture($1);
5845 0 0       0 if ($ignorecase) {
5846 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5847             }
5848             }
5849              
5850             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5851             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5852 8 50       16 if ($ignorecase) {
5853 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
5854             }
5855             else {
5856 8         36 $char[$i] = '@{[Elatin10::PREMATCH()]}';
5857             }
5858             }
5859              
5860             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5861             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5862 8 50       15 if ($ignorecase) {
5863 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
5864             }
5865             else {
5866 8         30 $char[$i] = '@{[Elatin10::MATCH()]}';
5867             }
5868             }
5869              
5870             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5871             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5872 6 50       11 if ($ignorecase) {
5873 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
5874             }
5875             else {
5876 6         25 $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5877             }
5878             }
5879              
5880             # ${ foo }
5881             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5882 0 0       0 if ($ignorecase) {
5883 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5884             }
5885             }
5886              
5887             # ${ ... }
5888             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5889 0         0 $char[$i] = e_capture($1);
5890 0 0       0 if ($ignorecase) {
5891 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5892             }
5893             }
5894              
5895             # $scalar or @array
5896             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5897 21         34 $char[$i] = e_string($char[$i]);
5898 21 100       65 if ($ignorecase) {
5899 11         45 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5900             }
5901             }
5902              
5903             # quote character before ? + * {
5904             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5905 138 100 33     944 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5906             }
5907             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5908 0         0 my $char = $char[$i-1];
5909 0 0       0 if ($char[$i] eq '{') {
5910 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5911             }
5912             else {
5913 0         0 die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5914             }
5915             }
5916             else {
5917 127         667 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5918             }
5919             }
5920             }
5921              
5922             # make regexp string
5923 641         715 $modifier =~ tr/i//d;
5924 641 50       1076 if ($left_e > $right_e) {
5925 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5926 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5927             }
5928             else {
5929 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5930             }
5931             }
5932 641 50 33     3115 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5933 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5934             }
5935             else {
5936 641         4382 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5937             }
5938             }
5939              
5940             #
5941             # double quote stuff
5942             #
5943             sub qq_stuff {
5944 180     180 0 184 my($delimiter,$end_delimiter,$stuff) = @_;
5945              
5946             # scalar variable or array variable
5947 180 100       301 if ($stuff =~ /\A [\$\@] /oxms) {
5948 100         275 return $stuff;
5949             }
5950              
5951             # quote by delimiter
5952 80         134 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         196  
5953 80         161 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5954 80 50       108 next if $char eq $delimiter;
5955 80 50       96 next if $char eq $end_delimiter;
5956 80 50       137 if (not $octet{$char}) {
5957 80         324 return join '', 'qq', $char, $stuff, $char;
5958             }
5959             }
5960 0         0 return join '', 'qq', '<', $stuff, '>';
5961             }
5962              
5963             #
5964             # escape regexp (m'', qr'', and m''b, qr''b)
5965             #
5966             sub e_qr_q {
5967 10     10 0 27 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5968 10   50     37 $modifier ||= '';
5969              
5970 10         13 $modifier =~ tr/p//d;
5971 10 50       20 if ($modifier =~ /([adlu])/oxms) {
5972 0         0 my $line = 0;
5973 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5974 0 0       0 if ($filename ne __FILE__) {
5975 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5976 0         0 last;
5977             }
5978             }
5979 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5980             }
5981              
5982 10         10 $slash = 'div';
5983              
5984             # literal null string pattern
5985 10 100       23 if ($string eq '') {
    50          
5986 8         7 $modifier =~ tr/bB//d;
5987 8         8 $modifier =~ tr/i//d;
5988 8         36 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5989             }
5990              
5991             # with /b /B modifier
5992             elsif ($modifier =~ tr/bB//d) {
5993 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5994             }
5995              
5996             # without /b /B modifier
5997             else {
5998 2         5 return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5999             }
6000             }
6001              
6002             #
6003             # escape regexp (m'', qr'')
6004             #
6005             sub e_qr_qt {
6006 2     2 0 5 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6007              
6008 2 50       6 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6009              
6010             # split regexp
6011 2         88 my @char = $string =~ /\G((?>
6012             [^\\\[\$\@\/] |
6013             [\x00-\xFF] |
6014             \[\^ |
6015             \[\: (?>[a-z]+) \:\] |
6016             \[\:\^ (?>[a-z]+) \:\] |
6017             [\$\@\/] |
6018             \\ (?:$q_char) |
6019             (?:$q_char)
6020             ))/oxmsg;
6021              
6022             # unescape character
6023 2         10 for (my $i=0; $i <= $#char; $i++) {
6024 2 50 33     14 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
6025             }
6026              
6027             # open character class [...]
6028 0         0 elsif ($char[$i] eq '[') {
6029 0         0 my $left = $i;
6030 0 0       0 if ($char[$i+1] eq ']') {
6031 0         0 $i++;
6032             }
6033 0         0 while (1) {
6034 0 0       0 if (++$i > $#char) {
6035 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6036             }
6037 0 0       0 if ($char[$i] eq ']') {
6038 0         0 my $right = $i;
6039              
6040             # [...]
6041 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6042              
6043 0         0 $i = $left;
6044 0         0 last;
6045             }
6046             }
6047             }
6048              
6049             # open character class [^...]
6050             elsif ($char[$i] eq '[^') {
6051 0         0 my $left = $i;
6052 0 0       0 if ($char[$i+1] eq ']') {
6053 0         0 $i++;
6054             }
6055 0         0 while (1) {
6056 0 0       0 if (++$i > $#char) {
6057 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6058             }
6059 0 0       0 if ($char[$i] eq ']') {
6060 0         0 my $right = $i;
6061              
6062             # [^...]
6063 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6064              
6065 0         0 $i = $left;
6066 0         0 last;
6067             }
6068             }
6069             }
6070              
6071             # escape $ @ / and \
6072             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6073 0         0 $char[$i] = '\\' . $char[$i];
6074             }
6075              
6076             # rewrite character class or escape character
6077             elsif (my $char = character_class($char[$i],$modifier)) {
6078 0         0 $char[$i] = $char;
6079             }
6080              
6081             # /i modifier
6082             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6083 0 0       0 if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6084 0         0 $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6085             }
6086             else {
6087 0         0 $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6088             }
6089             }
6090              
6091             # quote character before ? + * {
6092             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6093 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6094             }
6095             else {
6096 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6097             }
6098             }
6099             }
6100              
6101 2         4 $delimiter = '/';
6102 2         2 $end_delimiter = '/';
6103              
6104 2         3 $modifier =~ tr/i//d;
6105 2         17 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6106             }
6107              
6108             #
6109             # escape regexp (m''b, qr''b)
6110             #
6111             sub e_qr_qb {
6112 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6113              
6114             # split regexp
6115 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6116              
6117             # unescape character
6118 0         0 for (my $i=0; $i <= $#char; $i++) {
6119 0 0       0 if (0) {
    0          
6120             }
6121              
6122             # remain \\
6123 0         0 elsif ($char[$i] eq '\\\\') {
6124             }
6125              
6126             # escape $ @ / and \
6127             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6128 0         0 $char[$i] = '\\' . $char[$i];
6129             }
6130             }
6131              
6132 0         0 $delimiter = '/';
6133 0         0 $end_delimiter = '/';
6134 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6135             }
6136              
6137             #
6138             # escape regexp (s/here//)
6139             #
6140             sub e_s1 {
6141 76     76 0 132 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6142 76   100     215 $modifier ||= '';
6143              
6144 76         86 $modifier =~ tr/p//d;
6145 76 50       168 if ($modifier =~ /([adlu])/oxms) {
6146 0         0 my $line = 0;
6147 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6148 0 0       0 if ($filename ne __FILE__) {
6149 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6150 0         0 last;
6151             }
6152             }
6153 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6154             }
6155              
6156 76         90 $slash = 'div';
6157              
6158             # literal null string pattern
6159 76 100       214 if ($string eq '') {
    50          
6160 8         6 $modifier =~ tr/bB//d;
6161 8         7 $modifier =~ tr/i//d;
6162 8         52 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6163             }
6164              
6165             # /b /B modifier
6166             elsif ($modifier =~ tr/bB//d) {
6167              
6168             # choice again delimiter
6169 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
6170 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6171 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6172 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6173 0         0 $delimiter = '(';
6174 0         0 $end_delimiter = ')';
6175             }
6176             elsif (not $octet{'}'}) {
6177 0         0 $delimiter = '{';
6178 0         0 $end_delimiter = '}';
6179             }
6180             elsif (not $octet{']'}) {
6181 0         0 $delimiter = '[';
6182 0         0 $end_delimiter = ']';
6183             }
6184             elsif (not $octet{'>'}) {
6185 0         0 $delimiter = '<';
6186 0         0 $end_delimiter = '>';
6187             }
6188             else {
6189 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6190 0 0       0 if (not $octet{$char}) {
6191 0         0 $delimiter = $char;
6192 0         0 $end_delimiter = $char;
6193 0         0 last;
6194             }
6195             }
6196             }
6197             }
6198              
6199 0         0 my $prematch = '';
6200 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6201             }
6202              
6203 68 100       136 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6204 68         234 my $metachar = qr/[\@\\|[\]{^]/oxms;
6205              
6206             # split regexp
6207 68         14323 my @char = $string =~ /\G((?>
6208             [^\\\$\@\[\(] |
6209             \\ (?>[1-9][0-9]*) |
6210             \\g (?>\s*) (?>[1-9][0-9]*) |
6211             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6212             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6213             \\x (?>[0-9A-Fa-f]{1,2}) |
6214             \\ (?>[0-7]{2,3}) |
6215             \\c [\x40-\x5F] |
6216             \\x\{ (?>[0-9A-Fa-f]+) \} |
6217             \\o\{ (?>[0-7]+) \} |
6218             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6219             \\ $q_char |
6220             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6221             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6222             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6223             [\$\@] $qq_variable |
6224             \$ (?>\s* [0-9]+) |
6225             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6226             \$ \$ (?![\w\{]) |
6227             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6228             \[\^ |
6229             \[\: (?>[a-z]+) :\] |
6230             \[\:\^ (?>[a-z]+) :\] |
6231             \(\? |
6232             $q_char
6233             ))/oxmsg;
6234              
6235             # choice again delimiter
6236 68 50       437 if ($delimiter =~ / [\@:] /oxms) {
6237 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6238 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6239 0         0 $delimiter = '(';
6240 0         0 $end_delimiter = ')';
6241             }
6242             elsif (not $octet{'}'}) {
6243 0         0 $delimiter = '{';
6244 0         0 $end_delimiter = '}';
6245             }
6246             elsif (not $octet{']'}) {
6247 0         0 $delimiter = '[';
6248 0         0 $end_delimiter = ']';
6249             }
6250             elsif (not $octet{'>'}) {
6251 0         0 $delimiter = '<';
6252 0         0 $end_delimiter = '>';
6253             }
6254             else {
6255 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6256 0 0       0 if (not $octet{$char}) {
6257 0         0 $delimiter = $char;
6258 0         0 $end_delimiter = $char;
6259 0         0 last;
6260             }
6261             }
6262             }
6263             }
6264              
6265             # count '('
6266 68         99 my $parens = grep { $_ eq '(' } @char;
  253         313  
6267              
6268 68         70 my $left_e = 0;
6269 68         64 my $right_e = 0;
6270 68         167 for (my $i=0; $i <= $#char; $i++) {
6271              
6272             # "\L\u" --> "\u\L"
6273 195 50 33     1124 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6274 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6275             }
6276              
6277             # "\U\l" --> "\l\U"
6278             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6279 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6280             }
6281              
6282             # octal escape sequence
6283             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6284 1         2 $char[$i] = Elatin10::octchr($1);
6285             }
6286              
6287             # hexadecimal escape sequence
6288             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6289 1         3 $char[$i] = Elatin10::hexchr($1);
6290             }
6291              
6292             # \b{...} --> b\{...}
6293             # \B{...} --> B\{...}
6294             # \N{CHARNAME} --> N\{CHARNAME}
6295             # \p{PROPERTY} --> p\{PROPERTY}
6296             # \P{PROPERTY} --> P\{PROPERTY}
6297             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6298 0         0 $char[$i] = $1 . '\\' . $2;
6299             }
6300              
6301             # \p, \P, \X --> p, P, X
6302             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6303 0         0 $char[$i] = $1;
6304             }
6305              
6306 195 50 66     612 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          
6307             }
6308              
6309             # join separated multiple-octet
6310 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6311 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        
6312 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
6313             }
6314             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)) {
6315 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
6316             }
6317             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)) {
6318 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
6319             }
6320             }
6321              
6322             # open character class [...]
6323             elsif ($char[$i] eq '[') {
6324 13         13 my $left = $i;
6325 13 50       32 if ($char[$i+1] eq ']') {
6326 0         0 $i++;
6327             }
6328 13         11 while (1) {
6329 58 50       73 if (++$i > $#char) {
6330 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6331             }
6332 58 100       72 if ($char[$i] eq ']') {
6333 13         13 my $right = $i;
6334              
6335             # [...]
6336 13 50       56 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6337 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6338             }
6339             else {
6340 13         73 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6341             }
6342              
6343 13         13 $i = $left;
6344 13         30 last;
6345             }
6346             }
6347             }
6348              
6349             # open character class [^...]
6350             elsif ($char[$i] eq '[^') {
6351 0         0 my $left = $i;
6352 0 0       0 if ($char[$i+1] eq ']') {
6353 0         0 $i++;
6354             }
6355 0         0 while (1) {
6356 0 0       0 if (++$i > $#char) {
6357 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6358             }
6359 0 0       0 if ($char[$i] eq ']') {
6360 0         0 my $right = $i;
6361              
6362             # [^...]
6363 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6364 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6365             }
6366             else {
6367 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6368             }
6369              
6370 0         0 $i = $left;
6371 0         0 last;
6372             }
6373             }
6374             }
6375              
6376             # rewrite character class or escape character
6377             elsif (my $char = character_class($char[$i],$modifier)) {
6378 7         14 $char[$i] = $char;
6379             }
6380              
6381             # /i modifier
6382             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6383 3 50       4 if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6384 3         4 $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6385             }
6386             else {
6387 0         0 $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6388             }
6389             }
6390              
6391             # \u \l \U \L \F \Q \E
6392             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6393 0 0       0 if ($right_e < $left_e) {
6394 0         0 $char[$i] = '\\' . $char[$i];
6395             }
6396             }
6397             elsif ($char[$i] eq '\u') {
6398 0         0 $char[$i] = '@{[Elatin10::ucfirst qq<';
6399 0         0 $left_e++;
6400             }
6401             elsif ($char[$i] eq '\l') {
6402 0         0 $char[$i] = '@{[Elatin10::lcfirst qq<';
6403 0         0 $left_e++;
6404             }
6405             elsif ($char[$i] eq '\U') {
6406 0         0 $char[$i] = '@{[Elatin10::uc qq<';
6407 0         0 $left_e++;
6408             }
6409             elsif ($char[$i] eq '\L') {
6410 0         0 $char[$i] = '@{[Elatin10::lc qq<';
6411 0         0 $left_e++;
6412             }
6413             elsif ($char[$i] eq '\F') {
6414 0         0 $char[$i] = '@{[Elatin10::fc qq<';
6415 0         0 $left_e++;
6416             }
6417             elsif ($char[$i] eq '\Q') {
6418 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6419 0         0 $left_e++;
6420             }
6421             elsif ($char[$i] eq '\E') {
6422 0 0       0 if ($right_e < $left_e) {
6423 0         0 $char[$i] = '>]}';
6424 0         0 $right_e++;
6425             }
6426             else {
6427 0         0 $char[$i] = '';
6428             }
6429             }
6430             elsif ($char[$i] eq '\Q') {
6431 0         0 while (1) {
6432 0 0       0 if (++$i > $#char) {
6433 0         0 last;
6434             }
6435 0 0       0 if ($char[$i] eq '\E') {
6436 0         0 last;
6437             }
6438             }
6439             }
6440             elsif ($char[$i] eq '\E') {
6441             }
6442              
6443             # \0 --> \0
6444             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6445             }
6446              
6447             # \g{N}, \g{-N}
6448              
6449             # P.108 Using Simple Patterns
6450             # in Chapter 7: In the World of Regular Expressions
6451             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6452              
6453             # P.221 Capturing
6454             # in Chapter 5: Pattern Matching
6455             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6456              
6457             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6458             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6459             }
6460              
6461             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6462             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6463             }
6464              
6465             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6466             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6467             }
6468              
6469             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6470             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6471             }
6472              
6473             # $0 --> $0
6474             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6475 0 0       0 if ($ignorecase) {
6476 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6477             }
6478             }
6479             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6480 0 0       0 if ($ignorecase) {
6481 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6482             }
6483             }
6484              
6485             # $$ --> $$
6486             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6487             }
6488              
6489             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6490             # $1, $2, $3 --> $1, $2, $3 otherwise
6491             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6492 0         0 $char[$i] = e_capture($1);
6493 0 0       0 if ($ignorecase) {
6494 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6495             }
6496             }
6497             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6498 0         0 $char[$i] = e_capture($1);
6499 0 0       0 if ($ignorecase) {
6500 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6501             }
6502             }
6503              
6504             # $$foo[ ... ] --> $ $foo->[ ... ]
6505             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6506 0         0 $char[$i] = e_capture($1.'->'.$2);
6507 0 0       0 if ($ignorecase) {
6508 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6509             }
6510             }
6511              
6512             # $$foo{ ... } --> $ $foo->{ ... }
6513             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6514 0         0 $char[$i] = e_capture($1.'->'.$2);
6515 0 0       0 if ($ignorecase) {
6516 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6517             }
6518             }
6519              
6520             # $$foo
6521             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6522 0         0 $char[$i] = e_capture($1);
6523 0 0       0 if ($ignorecase) {
6524 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6525             }
6526             }
6527              
6528             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
6529             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6530 4 50       12 if ($ignorecase) {
6531 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
6532             }
6533             else {
6534 4         23 $char[$i] = '@{[Elatin10::PREMATCH()]}';
6535             }
6536             }
6537              
6538             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
6539             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6540 4 50       11 if ($ignorecase) {
6541 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
6542             }
6543             else {
6544 4         19 $char[$i] = '@{[Elatin10::MATCH()]}';
6545             }
6546             }
6547              
6548             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
6549             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6550 3 50       8 if ($ignorecase) {
6551 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
6552             }
6553             else {
6554 3         14 $char[$i] = '@{[Elatin10::POSTMATCH()]}';
6555             }
6556             }
6557              
6558             # ${ foo }
6559             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6560 0 0       0 if ($ignorecase) {
6561 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6562             }
6563             }
6564              
6565             # ${ ... }
6566             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6567 0         0 $char[$i] = e_capture($1);
6568 0 0       0 if ($ignorecase) {
6569 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6570             }
6571             }
6572              
6573             # $scalar or @array
6574             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6575 4         10 $char[$i] = e_string($char[$i]);
6576 4 50       40 if ($ignorecase) {
6577 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6578             }
6579             }
6580              
6581             # quote character before ? + * {
6582             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6583 13 50       42 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6584             }
6585             else {
6586 13         71 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6587             }
6588             }
6589             }
6590              
6591             # make regexp string
6592 68         97 my $prematch = '';
6593 68         82 $modifier =~ tr/i//d;
6594 68 50       181 if ($left_e > $right_e) {
6595 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6596             }
6597 68         665 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6598             }
6599              
6600             #
6601             # escape regexp (s'here'' or s'here''b)
6602             #
6603             sub e_s1_q {
6604 21     21 0 27 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6605 21   100     54 $modifier ||= '';
6606              
6607 21         20 $modifier =~ tr/p//d;
6608 21 50       32 if ($modifier =~ /([adlu])/oxms) {
6609 0         0 my $line = 0;
6610 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6611 0 0       0 if ($filename ne __FILE__) {
6612 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6613 0         0 last;
6614             }
6615             }
6616 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6617             }
6618              
6619 21         24 $slash = 'div';
6620              
6621             # literal null string pattern
6622 21 100       39 if ($string eq '') {
    50          
6623 8         8 $modifier =~ tr/bB//d;
6624 8         5 $modifier =~ tr/i//d;
6625 8         46 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6626             }
6627              
6628             # with /b /B modifier
6629             elsif ($modifier =~ tr/bB//d) {
6630 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6631             }
6632              
6633             # without /b /B modifier
6634             else {
6635 13         22 return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6636             }
6637             }
6638              
6639             #
6640             # escape regexp (s'here'')
6641             #
6642             sub e_s1_qt {
6643 13     13 0 17 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6644              
6645 13 50       21 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6646              
6647             # split regexp
6648 13         224 my @char = $string =~ /\G((?>
6649             [^\\\[\$\@\/] |
6650             [\x00-\xFF] |
6651             \[\^ |
6652             \[\: (?>[a-z]+) \:\] |
6653             \[\:\^ (?>[a-z]+) \:\] |
6654             [\$\@\/] |
6655             \\ (?:$q_char) |
6656             (?:$q_char)
6657             ))/oxmsg;
6658              
6659             # unescape character
6660 13         35 for (my $i=0; $i <= $#char; $i++) {
6661 25 50 33     113 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6662             }
6663              
6664             # open character class [...]
6665 0         0 elsif ($char[$i] eq '[') {
6666 0         0 my $left = $i;
6667 0 0       0 if ($char[$i+1] eq ']') {
6668 0         0 $i++;
6669             }
6670 0         0 while (1) {
6671 0 0       0 if (++$i > $#char) {
6672 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6673             }
6674 0 0       0 if ($char[$i] eq ']') {
6675 0         0 my $right = $i;
6676              
6677             # [...]
6678 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6679              
6680 0         0 $i = $left;
6681 0         0 last;
6682             }
6683             }
6684             }
6685              
6686             # open character class [^...]
6687             elsif ($char[$i] eq '[^') {
6688 0         0 my $left = $i;
6689 0 0       0 if ($char[$i+1] eq ']') {
6690 0         0 $i++;
6691             }
6692 0         0 while (1) {
6693 0 0       0 if (++$i > $#char) {
6694 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6695             }
6696 0 0       0 if ($char[$i] eq ']') {
6697 0         0 my $right = $i;
6698              
6699             # [^...]
6700 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6701              
6702 0         0 $i = $left;
6703 0         0 last;
6704             }
6705             }
6706             }
6707              
6708             # escape $ @ / and \
6709             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6710 0         0 $char[$i] = '\\' . $char[$i];
6711             }
6712              
6713             # rewrite character class or escape character
6714             elsif (my $char = character_class($char[$i],$modifier)) {
6715 6         13 $char[$i] = $char;
6716             }
6717              
6718             # /i modifier
6719             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6720 0 0       0 if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6721 0         0 $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6722             }
6723             else {
6724 0         0 $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6725             }
6726             }
6727              
6728             # quote character before ? + * {
6729             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6730 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6731             }
6732             else {
6733 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6734             }
6735             }
6736             }
6737              
6738 13         17 $modifier =~ tr/i//d;
6739 13         12 $delimiter = '/';
6740 13         12 $end_delimiter = '/';
6741 13         9 my $prematch = '';
6742 13         80 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6743             }
6744              
6745             #
6746             # escape regexp (s'here''b)
6747             #
6748             sub e_s1_qb {
6749 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6750              
6751             # split regexp
6752 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6753              
6754             # unescape character
6755 0         0 for (my $i=0; $i <= $#char; $i++) {
6756 0 0       0 if (0) {
    0          
6757             }
6758              
6759             # remain \\
6760 0         0 elsif ($char[$i] eq '\\\\') {
6761             }
6762              
6763             # escape $ @ / and \
6764             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6765 0         0 $char[$i] = '\\' . $char[$i];
6766             }
6767             }
6768              
6769 0         0 $delimiter = '/';
6770 0         0 $end_delimiter = '/';
6771 0         0 my $prematch = '';
6772 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6773             }
6774              
6775             #
6776             # escape regexp (s''here')
6777             #
6778             sub e_s2_q {
6779 16     16 0 20 my($ope,$delimiter,$end_delimiter,$string) = @_;
6780              
6781 16         15 $slash = 'div';
6782              
6783 16         108 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6784 16         40 for (my $i=0; $i <= $#char; $i++) {
6785 9 100       27 if (0) {
    100          
6786             }
6787              
6788             # not escape \\
6789 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6790             }
6791              
6792             # escape $ @ / and \
6793             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6794 5         11 $char[$i] = '\\' . $char[$i];
6795             }
6796             }
6797              
6798 16         40 return join '', $ope, $delimiter, @char, $end_delimiter;
6799             }
6800              
6801             #
6802             # escape regexp (s/here/and here/modifier)
6803             #
6804             sub e_sub {
6805 97     97 0 363 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6806 97   100     335 $modifier ||= '';
6807              
6808 97         134 $modifier =~ tr/p//d;
6809 97 50       225 if ($modifier =~ /([adlu])/oxms) {
6810 0         0 my $line = 0;
6811 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6812 0 0       0 if ($filename ne __FILE__) {
6813 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6814 0         0 last;
6815             }
6816             }
6817 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6818             }
6819              
6820 97 100       191 if ($variable eq '') {
6821 36         33 $variable = '$_';
6822 36         36 $bind_operator = ' =~ ';
6823             }
6824              
6825 97         90 $slash = 'div';
6826              
6827             # P.128 Start of match (or end of previous match): \G
6828             # P.130 Advanced Use of \G with Perl
6829             # in Chapter 3: Overview of Regular Expression Features and Flavors
6830             # P.312 Iterative Matching: Scalar Context, with /g
6831             # in Chapter 7: Perl
6832             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6833              
6834             # P.181 Where You Left Off: The \G Assertion
6835             # in Chapter 5: Pattern Matching
6836             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6837              
6838             # P.220 Where You Left Off: The \G Assertion
6839             # in Chapter 5: Pattern Matching
6840             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6841              
6842 97         100 my $e_modifier = $modifier =~ tr/e//d;
6843 97         110 my $r_modifier = $modifier =~ tr/r//d;
6844              
6845 97         96 my $my = '';
6846 97 50       191 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6847 0         0 $my = $variable;
6848 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6849 0         0 $variable =~ s/ = .+ \z//oxms;
6850             }
6851              
6852 97         166 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6853 97         112 $variable_basename =~ s/ \s+ \z//oxms;
6854              
6855             # quote replacement string
6856 97         96 my $e_replacement = '';
6857 97 100       170 if ($e_modifier >= 1) {
6858 17         24 $e_replacement = e_qq('', '', '', $replacement);
6859 17         15 $e_modifier--;
6860             }
6861             else {
6862 80 100       135 if ($delimiter2 eq "'") {
6863 16         39 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6864             }
6865             else {
6866 64         123 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6867             }
6868             }
6869              
6870 97         112 my $sub = '';
6871              
6872             # with /r
6873 97 100       162 if ($r_modifier) {
6874 8 100       12 if (0) {
6875             }
6876              
6877             # s///gr without multibyte anchoring
6878 0         0 elsif ($modifier =~ /g/oxms) {
6879 4 50       12 $sub = sprintf(
6880             # 1 2 3 4 5
6881             q,
6882              
6883             $variable, # 1
6884             ($delimiter1 eq "'") ? # 2
6885             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6886             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6887             $s_matched, # 3
6888             $e_replacement, # 4
6889             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 5
6890             );
6891             }
6892              
6893             # s///r
6894             else {
6895              
6896 4         2 my $prematch = q{$`};
6897              
6898 4 50       11 $sub = sprintf(
6899             # 1 2 3 4 5 6 7
6900             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin10::re_r=%s; %s"%s$Latin10::re_r$'" } : %s>,
6901              
6902             $variable, # 1
6903             ($delimiter1 eq "'") ? # 2
6904             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6905             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6906             $s_matched, # 3
6907             $e_replacement, # 4
6908             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 5
6909             $prematch, # 6
6910             $variable, # 7
6911             );
6912             }
6913              
6914             # $var !~ s///r doesn't make sense
6915 8 50       18 if ($bind_operator =~ / !~ /oxms) {
6916 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6917             }
6918             }
6919              
6920             # without /r
6921             else {
6922 89 100       162 if (0) {
6923             }
6924              
6925             # s///g without multibyte anchoring
6926 0         0 elsif ($modifier =~ /g/oxms) {
6927 22 100       57 $sub = sprintf(
    100          
6928             # 1 2 3 4 5 6 7 8
6929             q,
6930              
6931             $variable, # 1
6932             ($delimiter1 eq "'") ? # 2
6933             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6934             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6935             $s_matched, # 3
6936             $e_replacement, # 4
6937             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 5
6938             $variable, # 6
6939             $variable, # 7
6940             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6941             );
6942             }
6943              
6944             # s///
6945             else {
6946              
6947 67         74 my $prematch = q{$`};
6948              
6949 67 100       308 $sub = sprintf(
    100          
6950              
6951             ($bind_operator =~ / =~ /oxms) ?
6952              
6953             # 1 2 3 4 5 6 7 8
6954             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin10::re_r=%s; %s%s="%s$Latin10::re_r$'"; 1 } : undef> :
6955              
6956             # 1 2 3 4 5 6 7 8
6957             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin10::re_r=%s; %s%s="%s$Latin10::re_r$'"; undef }>,
6958              
6959             $variable, # 1
6960             $bind_operator, # 2
6961             ($delimiter1 eq "'") ? # 3
6962             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6963             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6964             $s_matched, # 4
6965             $e_replacement, # 5
6966             '$Latin10::re_r=CORE::eval $Latin10::re_r; ' x $e_modifier, # 6
6967             $variable, # 7
6968             $prematch, # 8
6969             );
6970             }
6971             }
6972              
6973             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6974 97 50       209 if ($my ne '') {
6975 0         0 $sub = "($my, $sub)[1]";
6976             }
6977              
6978             # clear s/// variable
6979 97         110 $sub_variable = '';
6980 97         82 $bind_operator = '';
6981              
6982 97         616 return $sub;
6983             }
6984              
6985             #
6986             # escape regexp of split qr//
6987             #
6988             sub e_split {
6989 74     74 0 182 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6990 74   100     288 $modifier ||= '';
6991              
6992 74         86 $modifier =~ tr/p//d;
6993 74 50       276 if ($modifier =~ /([adlu])/oxms) {
6994 0         0 my $line = 0;
6995 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6996 0 0       0 if ($filename ne __FILE__) {
6997 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6998 0         0 last;
6999             }
7000             }
7001 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
7002             }
7003              
7004 74         89 $slash = 'div';
7005              
7006             # /b /B modifier
7007 74 50       137 if ($modifier =~ tr/bB//d) {
7008 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7009             }
7010              
7011 74 50       128 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7012 74         258 my $metachar = qr/[\@\\|[\]{^]/oxms;
7013              
7014             # split regexp
7015 74         8085 my @char = $string =~ /\G((?>
7016             [^\\\$\@\[\(] |
7017             \\x (?>[0-9A-Fa-f]{1,2}) |
7018             \\ (?>[0-7]{2,3}) |
7019             \\c [\x40-\x5F] |
7020             \\x\{ (?>[0-9A-Fa-f]+) \} |
7021             \\o\{ (?>[0-7]+) \} |
7022             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7023             \\ $q_char |
7024             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7025             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7026             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7027             [\$\@] $qq_variable |
7028             \$ (?>\s* [0-9]+) |
7029             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7030             \$ \$ (?![\w\{]) |
7031             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7032             \[\^ |
7033             \[\: (?>[a-z]+) :\] |
7034             \[\:\^ (?>[a-z]+) :\] |
7035             \(\? |
7036             $q_char
7037             ))/oxmsg;
7038              
7039 74         210 my $left_e = 0;
7040 74         72 my $right_e = 0;
7041 74         288 for (my $i=0; $i <= $#char; $i++) {
7042              
7043             # "\L\u" --> "\u\L"
7044 249 50 33     1282 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7045 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7046             }
7047              
7048             # "\U\l" --> "\l\U"
7049             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7050 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7051             }
7052              
7053             # octal escape sequence
7054             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7055 1         3 $char[$i] = Elatin10::octchr($1);
7056             }
7057              
7058             # hexadecimal escape sequence
7059             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7060 1         2 $char[$i] = Elatin10::hexchr($1);
7061             }
7062              
7063             # \b{...} --> b\{...}
7064             # \B{...} --> B\{...}
7065             # \N{CHARNAME} --> N\{CHARNAME}
7066             # \p{PROPERTY} --> p\{PROPERTY}
7067             # \P{PROPERTY} --> P\{PROPERTY}
7068             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7069 0         0 $char[$i] = $1 . '\\' . $2;
7070             }
7071              
7072             # \p, \P, \X --> p, P, X
7073             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7074 0         0 $char[$i] = $1;
7075             }
7076              
7077 249 50 100     684 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          
7078             }
7079              
7080             # join separated multiple-octet
7081 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7082 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        
7083 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
7084             }
7085             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)) {
7086 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
7087             }
7088             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)) {
7089 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
7090             }
7091             }
7092              
7093             # open character class [...]
7094             elsif ($char[$i] eq '[') {
7095 3         3 my $left = $i;
7096 3 50       7 if ($char[$i+1] eq ']') {
7097 0         0 $i++;
7098             }
7099 3         2 while (1) {
7100 7 50       16 if (++$i > $#char) {
7101 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7102             }
7103 7 100       10 if ($char[$i] eq ']') {
7104 3         2 my $right = $i;
7105              
7106             # [...]
7107 3 50       10 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7108 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7109             }
7110             else {
7111 3         6 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7112             }
7113              
7114 3         3 $i = $left;
7115 3         6 last;
7116             }
7117             }
7118             }
7119              
7120             # open character class [^...]
7121             elsif ($char[$i] eq '[^') {
7122 0         0 my $left = $i;
7123 0 0       0 if ($char[$i+1] eq ']') {
7124 0         0 $i++;
7125             }
7126 0         0 while (1) {
7127 0 0       0 if (++$i > $#char) {
7128 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7129             }
7130 0 0       0 if ($char[$i] eq ']') {
7131 0         0 my $right = $i;
7132              
7133             # [^...]
7134 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7135 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7136             }
7137             else {
7138 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7139             }
7140              
7141 0         0 $i = $left;
7142 0         0 last;
7143             }
7144             }
7145             }
7146              
7147             # rewrite character class or escape character
7148             elsif (my $char = character_class($char[$i],$modifier)) {
7149 1         2 $char[$i] = $char;
7150             }
7151              
7152             # P.794 29.2.161. split
7153             # in Chapter 29: Functions
7154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7155              
7156             # P.951 split
7157             # in Chapter 27: Functions
7158             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7159              
7160             # said "The //m modifier is assumed when you split on the pattern /^/",
7161             # but perl5.008 is not so. Therefore, this software adds //m.
7162             # (and so on)
7163              
7164             # split(m/^/) --> split(m/^/m)
7165             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7166 7         29 $modifier .= 'm';
7167             }
7168              
7169             # /i modifier
7170             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7171 0 0       0 if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7172 0         0 $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7173             }
7174             else {
7175 0         0 $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7176             }
7177             }
7178              
7179             # \u \l \U \L \F \Q \E
7180             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7181 0 0       0 if ($right_e < $left_e) {
7182 0         0 $char[$i] = '\\' . $char[$i];
7183             }
7184             }
7185             elsif ($char[$i] eq '\u') {
7186 0         0 $char[$i] = '@{[Elatin10::ucfirst qq<';
7187 0         0 $left_e++;
7188             }
7189             elsif ($char[$i] eq '\l') {
7190 0         0 $char[$i] = '@{[Elatin10::lcfirst qq<';
7191 0         0 $left_e++;
7192             }
7193             elsif ($char[$i] eq '\U') {
7194 0         0 $char[$i] = '@{[Elatin10::uc qq<';
7195 0         0 $left_e++;
7196             }
7197             elsif ($char[$i] eq '\L') {
7198 0         0 $char[$i] = '@{[Elatin10::lc qq<';
7199 0         0 $left_e++;
7200             }
7201             elsif ($char[$i] eq '\F') {
7202 0         0 $char[$i] = '@{[Elatin10::fc qq<';
7203 0         0 $left_e++;
7204             }
7205             elsif ($char[$i] eq '\Q') {
7206 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7207 0         0 $left_e++;
7208             }
7209             elsif ($char[$i] eq '\E') {
7210 0 0       0 if ($right_e < $left_e) {
7211 0         0 $char[$i] = '>]}';
7212 0         0 $right_e++;
7213             }
7214             else {
7215 0         0 $char[$i] = '';
7216             }
7217             }
7218             elsif ($char[$i] eq '\Q') {
7219 0         0 while (1) {
7220 0 0       0 if (++$i > $#char) {
7221 0         0 last;
7222             }
7223 0 0       0 if ($char[$i] eq '\E') {
7224 0         0 last;
7225             }
7226             }
7227             }
7228             elsif ($char[$i] eq '\E') {
7229             }
7230              
7231             # $0 --> $0
7232             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7233 0 0       0 if ($ignorecase) {
7234 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7235             }
7236             }
7237             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7238 0 0       0 if ($ignorecase) {
7239 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7240             }
7241             }
7242              
7243             # $$ --> $$
7244             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7245             }
7246              
7247             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7248             # $1, $2, $3 --> $1, $2, $3 otherwise
7249             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7250 0         0 $char[$i] = e_capture($1);
7251 0 0       0 if ($ignorecase) {
7252 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7253             }
7254             }
7255             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7256 0         0 $char[$i] = e_capture($1);
7257 0 0       0 if ($ignorecase) {
7258 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7259             }
7260             }
7261              
7262             # $$foo[ ... ] --> $ $foo->[ ... ]
7263             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7264 0         0 $char[$i] = e_capture($1.'->'.$2);
7265 0 0       0 if ($ignorecase) {
7266 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7267             }
7268             }
7269              
7270             # $$foo{ ... } --> $ $foo->{ ... }
7271             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7272 0         0 $char[$i] = e_capture($1.'->'.$2);
7273 0 0       0 if ($ignorecase) {
7274 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7275             }
7276             }
7277              
7278             # $$foo
7279             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7280 0         0 $char[$i] = e_capture($1);
7281 0 0       0 if ($ignorecase) {
7282 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7283             }
7284             }
7285              
7286             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
7287             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7288 12 50       19 if ($ignorecase) {
7289 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
7290             }
7291             else {
7292 12         89 $char[$i] = '@{[Elatin10::PREMATCH()]}';
7293             }
7294             }
7295              
7296             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
7297             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7298 12 50       21 if ($ignorecase) {
7299 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
7300             }
7301             else {
7302 12         70 $char[$i] = '@{[Elatin10::MATCH()]}';
7303             }
7304             }
7305              
7306             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
7307             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7308 9 50       14 if ($ignorecase) {
7309 0         0 $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
7310             }
7311             else {
7312 9         54 $char[$i] = '@{[Elatin10::POSTMATCH()]}';
7313             }
7314             }
7315              
7316             # ${ foo }
7317             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7318 0 0       0 if ($ignorecase) {
7319 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $1 . ')]}';
7320             }
7321             }
7322              
7323             # ${ ... }
7324             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7325 0         0 $char[$i] = e_capture($1);
7326 0 0       0 if ($ignorecase) {
7327 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7328             }
7329             }
7330              
7331             # $scalar or @array
7332             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7333 3         6 $char[$i] = e_string($char[$i]);
7334 3 50       16 if ($ignorecase) {
7335 0         0 $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7336             }
7337             }
7338              
7339             # quote character before ? + * {
7340             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7341 1 50       6 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7342             }
7343             else {
7344 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7345             }
7346             }
7347             }
7348              
7349             # make regexp string
7350 74         91 $modifier =~ tr/i//d;
7351 74 50       135 if ($left_e > $right_e) {
7352 0         0 return join '', 'Elatin10::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7353             }
7354 74         655 return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7355             }
7356              
7357             #
7358             # escape regexp of split qr''
7359             #
7360             sub e_split_q {
7361 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7362 0   0       $modifier ||= '';
7363              
7364 0           $modifier =~ tr/p//d;
7365 0 0         if ($modifier =~ /([adlu])/oxms) {
7366 0           my $line = 0;
7367 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7368 0 0         if ($filename ne __FILE__) {
7369 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7370 0           last;
7371             }
7372             }
7373 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7374             }
7375              
7376 0           $slash = 'div';
7377              
7378             # /b /B modifier
7379 0 0         if ($modifier =~ tr/bB//d) {
7380 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7381             }
7382              
7383 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7384              
7385             # split regexp
7386 0           my @char = $string =~ /\G((?>
7387             [^\\\[] |
7388             [\x00-\xFF] |
7389             \[\^ |
7390             \[\: (?>[a-z]+) \:\] |
7391             \[\:\^ (?>[a-z]+) \:\] |
7392             \\ (?:$q_char) |
7393             (?:$q_char)
7394             ))/oxmsg;
7395              
7396             # unescape character
7397 0           for (my $i=0; $i <= $#char; $i++) {
7398 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7399             }
7400              
7401             # open character class [...]
7402 0           elsif ($char[$i] eq '[') {
7403 0           my $left = $i;
7404 0 0         if ($char[$i+1] eq ']') {
7405 0           $i++;
7406             }
7407 0           while (1) {
7408 0 0         if (++$i > $#char) {
7409 0           die __FILE__, ": Unmatched [] in regexp\n";
7410             }
7411 0 0         if ($char[$i] eq ']') {
7412 0           my $right = $i;
7413              
7414             # [...]
7415 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7416              
7417 0           $i = $left;
7418 0           last;
7419             }
7420             }
7421             }
7422              
7423             # open character class [^...]
7424             elsif ($char[$i] eq '[^') {
7425 0           my $left = $i;
7426 0 0         if ($char[$i+1] eq ']') {
7427 0           $i++;
7428             }
7429 0           while (1) {
7430 0 0         if (++$i > $#char) {
7431 0           die __FILE__, ": Unmatched [] in regexp\n";
7432             }
7433 0 0         if ($char[$i] eq ']') {
7434 0           my $right = $i;
7435              
7436             # [^...]
7437 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7438              
7439 0           $i = $left;
7440 0           last;
7441             }
7442             }
7443             }
7444              
7445             # rewrite character class or escape character
7446             elsif (my $char = character_class($char[$i],$modifier)) {
7447 0           $char[$i] = $char;
7448             }
7449              
7450             # split(m/^/) --> split(m/^/m)
7451             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7452 0           $modifier .= 'm';
7453             }
7454              
7455             # /i modifier
7456             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7457 0 0         if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7458 0           $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7459             }
7460             else {
7461 0           $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7462             }
7463             }
7464              
7465             # quote character before ? + * {
7466             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7467 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7468             }
7469             else {
7470 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7471             }
7472             }
7473             }
7474              
7475 0           $modifier =~ tr/i//d;
7476 0           return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7477             }
7478              
7479             #
7480             # instead of Carp::carp
7481             #
7482             sub carp {
7483 0     0 0   my($package,$filename,$line) = caller(1);
7484 0           print STDERR "@_ at $filename line $line.\n";
7485             }
7486              
7487             #
7488             # instead of Carp::croak
7489             #
7490             sub croak {
7491 0     0 0   my($package,$filename,$line) = caller(1);
7492 0           print STDERR "@_ at $filename line $line.\n";
7493 0           die "\n";
7494             }
7495              
7496             #
7497             # instead of Carp::cluck
7498             #
7499             sub cluck {
7500 0     0 0   my $i = 0;
7501 0           my @cluck = ();
7502 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7503 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7504 0           $i++;
7505             }
7506 0           print STDERR CORE::reverse @cluck;
7507 0           print STDERR "\n";
7508 0           carp @_;
7509             }
7510              
7511             #
7512             # instead of Carp::confess
7513             #
7514             sub confess {
7515 0     0 0   my $i = 0;
7516 0           my @confess = ();
7517 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7518 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7519 0           $i++;
7520             }
7521 0           print STDERR CORE::reverse @confess;
7522 0           print STDERR "\n";
7523 0           croak @_;
7524             }
7525              
7526             1;
7527              
7528             __END__