File Coverage

blib/lib/Elatin10.pm
Criterion Covered Total %
statement 905 2814 32.1
branch 890 2412 36.9
condition 98 355 27.6
subroutine 54 113 47.7
pod 7 74 9.4
total 1954 5768 33.8


line stmt bran cond sub pod time code
1             package Elatin10;
2 206     206   1257 use strict;
  206         411  
  206         22175  
3 206 50   206   3830 BEGIN { $INC{'warnings.pm'} = '' if $] < 5.006 } use warnings;
  206     206   1062  
  206         329  
  206         6036  
4             ######################################################################
5             #
6             # Elatin10 - Run-time routines for Latin10.pm
7             #
8             # http://search.cpan.org/dist/Char-Latin10/
9             #
10             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
11             ######################################################################
12              
13 206     206   3460 use 5.00503; # Galapagos Consensus 1998 for primetools
  206         752  
14             # use 5.008001; # Lancaster Consensus 2013 for toolchains
15              
16             # 12.3. Delaying use Until Runtime
17             # in Chapter 12. Packages, Libraries, and Modules
18             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
19             # (and so on)
20              
21             # Version numbers should be boring
22             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
23             # For the impatient, the disinterested or those who just want to follow
24             # a recipe, my advice for all modules is this:
25             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
26             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
27              
28 206     206   1043 use vars qw($VERSION);
  206         402  
  206         56693  
29             $VERSION = '1.22';
30             $VERSION = $VERSION;
31              
32             BEGIN {
33 206 50   206   1215 if ($^X =~ / jperl /oxmsi) {
34 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
35             }
36 206         327 if (CORE::ord('A') == 193) {
37             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
38             }
39 206         27113 if (CORE::ord('A') != 0x41) {
40             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
41             }
42             }
43              
44             BEGIN {
45              
46             # instead of utf8.pm
47 206     206   14659 CORE::eval q{
  206     206   15339  
  206     66   401  
  206         26147  
  0         0  
  0         0  
  0         0  
  0         0  
48             no warnings qw(redefine);
49             *utf8::upgrade = sub { CORE::length $_[0] };
50             *utf8::downgrade = sub { 1 };
51             *utf8::encode = sub { };
52             *utf8::decode = sub { 1 };
53             *utf8::is_utf8 = sub { };
54             *utf8::valid = sub { 1 };
55             };
56 206 50       81481 if ($@) {
57 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
58 0         0 *utf8::downgrade = sub { 1 };
  0         0  
59 0         0 *utf8::encode = sub { };
60 0         0 *utf8::decode = sub { 1 };
  0         0  
61 0         0 *utf8::is_utf8 = sub { };
62 0         0 *utf8::valid = sub { 1 };
  0         0  
63             }
64             }
65              
66             # instead of Symbol.pm
67 0         0 BEGIN {
68             sub gensym () {
69 0 0   0 0 0 if ($] < 5.006) {
70 0         0 return \do { local *_ };
  0         0  
71             }
72             else {
73 0         0 return undef;
74             }
75             }
76              
77             sub qualify ($$) {
78 0     0 0 0 my($name) = @_;
79              
80 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
81 0         0 return $name;
82             }
83             elsif (Elatin10::index($name,'::') >= 0) {
84 0         0 return $name;
85             }
86             elsif (Elatin10::index($name,"'") >= 0) {
87 0         0 return $name;
88             }
89              
90             # special character, "^xyz"
91             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
92              
93             # RGS 2001-11-05 : translate leading ^X to control-char
94 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
95 0         0 return 'main::' . $name;
96             }
97              
98             # Global names
99             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
100 0         0 return 'main::' . $name;
101             }
102              
103             # or other
104             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
105 0         0 return 'main::' . $name;
106             }
107              
108             elsif (defined $_[1]) {
109 0         0 return $_[1] . '::' . $name;
110             }
111             else {
112 0         0 return (caller)[0] . '::' . $name;
113             }
114             }
115              
116             sub qualify_to_ref ($;$) {
117 0 0   0 0 0 if (defined $_[1]) {
118 206     206   1611 no strict qw(refs);
  206         614  
  206         16880  
119 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
120             }
121             else {
122 206     206   1242 no strict qw(refs);
  206     0   472  
  206         50115  
123 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
124             }
125             }
126             }
127              
128             # P.714 29.2.39. flock
129             # in Chapter 29: Functions
130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
131              
132             # P.863 flock
133             # in Chapter 27: Functions
134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
135              
136             sub LOCK_SH() {1}
137             sub LOCK_EX() {2}
138             sub LOCK_UN() {8}
139             sub LOCK_NB() {4}
140              
141             # instead of Carp.pm
142             sub carp;
143             sub croak;
144             sub cluck;
145             sub confess;
146              
147             # 6.18. Matching Multiple-Byte Characters
148             # in Chapter 6. Pattern Matching
149             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
150             # (and so on)
151              
152             # regexp of character
153             my $your_char = q{[\x00-\xFF]};
154 206     206   1322 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  206         417  
  206         12193  
155 206     206   1119 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  206         455  
  206         382564  
156              
157             #
158             # Latin-10 character range per length
159             #
160             my %range_tr = ();
161              
162             #
163             # Latin-10 case conversion
164             #
165             my %lc = ();
166             @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)} =
167             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
168             my %uc = ();
169             @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)} =
170             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);
171             my %fc = ();
172             @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)} =
173             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);
174              
175             if (0) {
176             }
177              
178             elsif (__PACKAGE__ =~ / \b Elatin10 \z/oxms) {
179             %range_tr = (
180             1 => [ [0x00..0xFF],
181             ],
182             );
183              
184             %lc = (%lc,
185             "\xA1" => "\xA2", # LATIN LETTER A WITH OGONEK
186             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
187             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
188             "\xAA" => "\xBA", # LATIN LETTER S WITH COMMA BELOW
189             "\xAC" => "\xAE", # LATIN LETTER Z WITH ACUTE
190             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
191             "\xB2" => "\xB9", # LATIN LETTER C WITH CARON
192             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
193             "\xBC" => "\xBD", # LATIN LIGATURE OE
194             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
195             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
196             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
197             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
198             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
199             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
200             "\xC5" => "\xE5", # LATIN LETTER C WITH ACUTE
201             "\xC6" => "\xE6", # LATIN LETTER AE
202             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
203             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
204             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
205             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
206             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
207             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
208             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
209             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
210             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
211             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
212             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
213             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
214             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
215             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
216             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
217             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
218             "\xD7" => "\xF7", # LATIN LETTER S WITH ACUTE
219             "\xD8" => "\xF8", # LATIN LETTER U WITH DOUBLE ACUTE
220             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
221             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
222             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
223             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
224             "\xDD" => "\xFD", # LATIN LETTER E WITH OGONEK
225             "\xDE" => "\xFE", # LATIN LETTER T WITH COMMA BELOW
226             );
227              
228             %uc = (%uc,
229             "\xA2" => "\xA1", # LATIN LETTER A WITH OGONEK
230             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
231             "\xAE" => "\xAC", # LATIN LETTER Z WITH ACUTE
232             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
233             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
234             "\xB9" => "\xB2", # LATIN LETTER C WITH CARON
235             "\xBA" => "\xAA", # LATIN LETTER S WITH COMMA BELOW
236             "\xBD" => "\xBC", # LATIN LIGATURE OE
237             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
238             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
239             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
240             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
241             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
242             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
243             "\xE5" => "\xC5", # LATIN LETTER C WITH ACUTE
244             "\xE6" => "\xC6", # LATIN LETTER AE
245             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
246             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
247             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
248             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
249             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
250             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
251             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
252             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
253             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
254             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
255             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
256             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
257             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
258             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
259             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
260             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
261             "\xF7" => "\xD7", # LATIN LETTER S WITH ACUTE
262             "\xF8" => "\xD8", # LATIN LETTER U WITH DOUBLE ACUTE
263             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
264             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
265             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
266             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
267             "\xFD" => "\xDD", # LATIN LETTER E WITH OGONEK
268             "\xFE" => "\xDE", # LATIN LETTER T WITH COMMA BELOW
269             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
270             );
271              
272             %fc = (%fc,
273             "\xA1" => "\xA2", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
274             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
275             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
276             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH COMMA BELOW --> LATIN SMALL LETTER S WITH COMMA BELOW
277             "\xAC" => "\xAE", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
278             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
279             "\xB2" => "\xB9", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
280             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
281             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
282             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
283             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
284             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
285             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
286             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
287             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
288             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
289             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
290             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
291             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
292             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
293             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
294             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
295             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
296             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
297             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
298             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
299             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
300             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
301             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
302             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
303             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
304             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
305             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
306             "\xD7" => "\xF7", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
307             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
308             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
309             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
310             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
311             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
312             "\xDD" => "\xFD", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
313             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH COMMA BELOW --> LATIN SMALL LETTER T WITH COMMA BELOW
314             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
315             );
316             }
317              
318             else {
319             croak "Don't know my package name '@{[__PACKAGE__]}'";
320             }
321              
322             #
323             # @ARGV wildcard globbing
324             #
325             sub import {
326              
327 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
328 0         0 my @argv = ();
329 0         0 for (@ARGV) {
330              
331             # has space
332 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
333 0 0       0 if (my @glob = Elatin10::glob(qq{"$_"})) {
334 0         0 push @argv, @glob;
335             }
336             else {
337 0         0 push @argv, $_;
338             }
339             }
340              
341             # has wildcard metachar
342             elsif (/\A (?:$q_char)*? [*?] /oxms) {
343 0 0       0 if (my @glob = Elatin10::glob($_)) {
344 0         0 push @argv, @glob;
345             }
346             else {
347 0         0 push @argv, $_;
348             }
349             }
350              
351             # no wildcard globbing
352             else {
353 0         0 push @argv, $_;
354             }
355             }
356 0         0 @ARGV = @argv;
357             }
358              
359 0         0 *Char::ord = \&Latin10::ord;
360 0         0 *Char::ord_ = \&Latin10::ord_;
361 0         0 *Char::reverse = \&Latin10::reverse;
362 0         0 *Char::getc = \&Latin10::getc;
363 0         0 *Char::length = \&Latin10::length;
364 0         0 *Char::substr = \&Latin10::substr;
365 0         0 *Char::index = \&Latin10::index;
366 0         0 *Char::rindex = \&Latin10::rindex;
367 0         0 *Char::eval = \&Latin10::eval;
368 0         0 *Char::escape = \&Latin10::escape;
369 0         0 *Char::escape_token = \&Latin10::escape_token;
370 0         0 *Char::escape_script = \&Latin10::escape_script;
371             }
372              
373             # P.230 Care with Prototypes
374             # in Chapter 6: Subroutines
375             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
376             #
377             # If you aren't careful, you can get yourself into trouble with prototypes.
378             # But if you are careful, you can do a lot of neat things with them. This is
379             # all very powerful, of course, and should only be used in moderation to make
380             # the world a better place.
381              
382             # P.332 Care with Prototypes
383             # in Chapter 7: Subroutines
384             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
385             #
386             # If you aren't careful, you can get yourself into trouble with prototypes.
387             # But if you are careful, you can do a lot of neat things with them. This is
388             # all very powerful, of course, and should only be used in moderation to make
389             # the world a better place.
390              
391             #
392             # Prototypes of subroutines
393             #
394       0     sub unimport {}
395             sub Elatin10::split(;$$$);
396             sub Elatin10::tr($$$$;$);
397             sub Elatin10::chop(@);
398             sub Elatin10::index($$;$);
399             sub Elatin10::rindex($$;$);
400             sub Elatin10::lcfirst(@);
401             sub Elatin10::lcfirst_();
402             sub Elatin10::lc(@);
403             sub Elatin10::lc_();
404             sub Elatin10::ucfirst(@);
405             sub Elatin10::ucfirst_();
406             sub Elatin10::uc(@);
407             sub Elatin10::uc_();
408             sub Elatin10::fc(@);
409             sub Elatin10::fc_();
410             sub Elatin10::ignorecase;
411             sub Elatin10::classic_character_class;
412             sub Elatin10::capture;
413             sub Elatin10::chr(;$);
414             sub Elatin10::chr_();
415             sub Elatin10::glob($);
416             sub Elatin10::glob_();
417              
418             sub Latin10::ord(;$);
419             sub Latin10::ord_();
420             sub Latin10::reverse(@);
421             sub Latin10::getc(;*@);
422             sub Latin10::length(;$);
423             sub Latin10::substr($$;$$);
424             sub Latin10::index($$;$);
425             sub Latin10::rindex($$;$);
426             sub Latin10::escape(;$);
427              
428             #
429             # Regexp work
430             #
431 206         17926 use vars qw(
432             $re_a
433             $re_t
434             $re_n
435             $re_r
436 206     206   1534 );
  206         428  
437              
438             #
439             # Character class
440             #
441 206         2135962 use vars qw(
442             $dot
443             $dot_s
444             $eD
445             $eS
446             $eW
447             $eH
448             $eV
449             $eR
450             $eN
451             $not_alnum
452             $not_alpha
453             $not_ascii
454             $not_blank
455             $not_cntrl
456             $not_digit
457             $not_graph
458             $not_lower
459             $not_lower_i
460             $not_print
461             $not_punct
462             $not_space
463             $not_upper
464             $not_upper_i
465             $not_word
466             $not_xdigit
467             $eb
468             $eB
469 206     206   1248 );
  206         379  
470              
471             ${Elatin10::dot} = qr{(?>[^\x0A])};
472             ${Elatin10::dot_s} = qr{(?>[\x00-\xFF])};
473             ${Elatin10::eD} = qr{(?>[^0-9])};
474              
475             # Vertical tabs are now whitespace
476             # \s in a regex now matches a vertical tab in all circumstances.
477             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
478             # ${Elatin10::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
479             # ${Elatin10::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
480             ${Elatin10::eS} = qr{(?>[^\s])};
481              
482             ${Elatin10::eW} = qr{(?>[^0-9A-Z_a-z])};
483             ${Elatin10::eH} = qr{(?>[^\x09\x20])};
484             ${Elatin10::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
485             ${Elatin10::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
486             ${Elatin10::eN} = qr{(?>[^\x0A])};
487             ${Elatin10::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
488             ${Elatin10::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
489             ${Elatin10::not_ascii} = qr{(?>[^\x00-\x7F])};
490             ${Elatin10::not_blank} = qr{(?>[^\x09\x20])};
491             ${Elatin10::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
492             ${Elatin10::not_digit} = qr{(?>[^\x30-\x39])};
493             ${Elatin10::not_graph} = qr{(?>[^\x21-\x7F])};
494             ${Elatin10::not_lower} = qr{(?>[^\x61-\x7A])};
495             ${Elatin10::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
496             # ${Elatin10::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
497             ${Elatin10::not_print} = qr{(?>[^\x20-\x7F])};
498             ${Elatin10::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
499             ${Elatin10::not_space} = qr{(?>[^\s\x0B])};
500             ${Elatin10::not_upper} = qr{(?>[^\x41-\x5A])};
501             ${Elatin10::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
502             # ${Elatin10::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
503             ${Elatin10::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
504             ${Elatin10::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
505             ${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))};
506             ${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]))};
507              
508             # avoid: Name "Elatin10::foo" used only once: possible typo at here.
509             ${Elatin10::dot} = ${Elatin10::dot};
510             ${Elatin10::dot_s} = ${Elatin10::dot_s};
511             ${Elatin10::eD} = ${Elatin10::eD};
512             ${Elatin10::eS} = ${Elatin10::eS};
513             ${Elatin10::eW} = ${Elatin10::eW};
514             ${Elatin10::eH} = ${Elatin10::eH};
515             ${Elatin10::eV} = ${Elatin10::eV};
516             ${Elatin10::eR} = ${Elatin10::eR};
517             ${Elatin10::eN} = ${Elatin10::eN};
518             ${Elatin10::not_alnum} = ${Elatin10::not_alnum};
519             ${Elatin10::not_alpha} = ${Elatin10::not_alpha};
520             ${Elatin10::not_ascii} = ${Elatin10::not_ascii};
521             ${Elatin10::not_blank} = ${Elatin10::not_blank};
522             ${Elatin10::not_cntrl} = ${Elatin10::not_cntrl};
523             ${Elatin10::not_digit} = ${Elatin10::not_digit};
524             ${Elatin10::not_graph} = ${Elatin10::not_graph};
525             ${Elatin10::not_lower} = ${Elatin10::not_lower};
526             ${Elatin10::not_lower_i} = ${Elatin10::not_lower_i};
527             ${Elatin10::not_print} = ${Elatin10::not_print};
528             ${Elatin10::not_punct} = ${Elatin10::not_punct};
529             ${Elatin10::not_space} = ${Elatin10::not_space};
530             ${Elatin10::not_upper} = ${Elatin10::not_upper};
531             ${Elatin10::not_upper_i} = ${Elatin10::not_upper_i};
532             ${Elatin10::not_word} = ${Elatin10::not_word};
533             ${Elatin10::not_xdigit} = ${Elatin10::not_xdigit};
534             ${Elatin10::eb} = ${Elatin10::eb};
535             ${Elatin10::eB} = ${Elatin10::eB};
536              
537             #
538             # Latin-10 split
539             #
540             sub Elatin10::split(;$$$) {
541              
542             # P.794 29.2.161. split
543             # in Chapter 29: Functions
544             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
545              
546             # P.951 split
547             # in Chapter 27: Functions
548             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
549              
550 0     0 0 0 my $pattern = $_[0];
551 0         0 my $string = $_[1];
552 0         0 my $limit = $_[2];
553              
554             # if $pattern is also omitted or is the literal space, " "
555 0 0       0 if (not defined $pattern) {
556 0         0 $pattern = ' ';
557             }
558              
559             # if $string is omitted, the function splits the $_ string
560 0 0       0 if (not defined $string) {
561 0 0       0 if (defined $_) {
562 0         0 $string = $_;
563             }
564             else {
565 0         0 $string = '';
566             }
567             }
568              
569 0         0 my @split = ();
570              
571             # when string is empty
572 0 0       0 if ($string eq '') {
    0          
573              
574             # resulting list value in list context
575 0 0       0 if (wantarray) {
576 0         0 return @split;
577             }
578              
579             # count of substrings in scalar context
580             else {
581 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
582 0         0 @_ = @split;
583 0         0 return scalar @_;
584             }
585             }
586              
587             # split's first argument is more consistently interpreted
588             #
589             # After some changes earlier in v5.17, split's behavior has been simplified:
590             # if the PATTERN argument evaluates to a string containing one space, it is
591             # treated the way that a literal string containing one space once was.
592             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
593              
594             # if $pattern is also omitted or is the literal space, " ", the function splits
595             # on whitespace, /\s+/, after skipping any leading whitespace
596             # (and so on)
597              
598             elsif ($pattern eq ' ') {
599 0 0       0 if (not defined $limit) {
600 0         0 return CORE::split(' ', $string);
601             }
602             else {
603 0         0 return CORE::split(' ', $string, $limit);
604             }
605             }
606              
607             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
608 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
609              
610             # a pattern capable of matching either the null string or something longer than the
611             # null string will split the value of $string into separate characters wherever it
612             # matches the null string between characters
613             # (and so on)
614              
615 0 0       0 if ('' =~ / \A $pattern \z /xms) {
616 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
617 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
618              
619             # P.1024 Appendix W.10 Multibyte Processing
620             # of ISBN 1-56592-224-7 CJKV Information Processing
621             # (and so on)
622              
623             # the //m modifier is assumed when you split on the pattern /^/
624             # (and so on)
625              
626 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
627             # V
628 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
629              
630             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
631             # is included in the resulting list, interspersed with the fields that are ordinarily returned
632             # (and so on)
633              
634 0         0 local $@;
635 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
636 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
637 0         0 push @split, CORE::eval('$' . $digit);
638             }
639             }
640             }
641              
642             else {
643 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
644              
645 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
646             # V
647 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
648 0         0 local $@;
649 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
650 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
651 0         0 push @split, CORE::eval('$' . $digit);
652             }
653             }
654             }
655             }
656              
657             elsif ($limit > 0) {
658 0 0       0 if ('' =~ / \A $pattern \z /xms) {
659 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
660 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
661              
662 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
663             # V
664 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
665 0         0 local $@;
666 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
667 0         0 push @split, CORE::eval('$' . $digit);
668             }
669             }
670             }
671             }
672             else {
673 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
674 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
675              
676 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
677             # V
678 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
679 0         0 local $@;
680 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
681 0         0 push @split, CORE::eval('$' . $digit);
682             }
683             }
684             }
685             }
686             }
687              
688 0 0       0 if (CORE::length($string) > 0) {
689 0         0 push @split, $string;
690             }
691              
692             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
693 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
694 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
695 0         0 pop @split;
696             }
697             }
698              
699             # resulting list value in list context
700 0 0       0 if (wantarray) {
701 0         0 return @split;
702             }
703              
704             # count of substrings in scalar context
705             else {
706 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
707 0         0 @_ = @split;
708 0         0 return scalar @_;
709             }
710             }
711              
712             #
713             # get last subexpression offsets
714             #
715             sub _last_subexpression_offsets {
716 0     0   0 my $pattern = $_[0];
717              
718             # remove comment
719 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
720              
721 0         0 my $modifier = '';
722 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
723 0         0 $modifier = $1;
724 0         0 $modifier =~ s/-[A-Za-z]*//;
725             }
726              
727             # with /x modifier
728 0         0 my @char = ();
729 0 0       0 if ($modifier =~ /x/oxms) {
730 0         0 @char = $pattern =~ /\G((?>
731             [^\\\#\[\(] |
732             \\ $q_char |
733             \# (?>[^\n]*) $ |
734             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
735             \(\? |
736             $q_char
737             ))/oxmsg;
738             }
739              
740             # without /x modifier
741             else {
742 0         0 @char = $pattern =~ /\G((?>
743             [^\\\[\(] |
744             \\ $q_char |
745             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
746             \(\? |
747             $q_char
748             ))/oxmsg;
749             }
750              
751 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
752             }
753              
754             #
755             # Latin-10 transliteration (tr///)
756             #
757             sub Elatin10::tr($$$$;$) {
758              
759 0     0 0 0 my $bind_operator = $_[1];
760 0         0 my $searchlist = $_[2];
761 0         0 my $replacementlist = $_[3];
762 0   0     0 my $modifier = $_[4] || '';
763              
764 0 0       0 if ($modifier =~ /r/oxms) {
765 0 0       0 if ($bind_operator =~ / !~ /oxms) {
766 0         0 croak "Using !~ with tr///r doesn't make sense";
767             }
768             }
769              
770 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
771 0         0 my @searchlist = _charlist_tr($searchlist);
772 0         0 my @replacementlist = _charlist_tr($replacementlist);
773              
774 0         0 my %tr = ();
775 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
776 0 0       0 if (not exists $tr{$searchlist[$i]}) {
777 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
778 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
779             }
780             elsif ($modifier =~ /d/oxms) {
781 0         0 $tr{$searchlist[$i]} = '';
782             }
783             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
784 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
785             }
786             else {
787 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
788             }
789             }
790             }
791              
792 0         0 my $tr = 0;
793 0         0 my $replaced = '';
794 0 0       0 if ($modifier =~ /c/oxms) {
795 0         0 while (defined(my $char = shift @char)) {
796 0 0       0 if (not exists $tr{$char}) {
797 0 0       0 if (defined $replacementlist[-1]) {
798 0         0 $replaced .= $replacementlist[-1];
799             }
800 0         0 $tr++;
801 0 0       0 if ($modifier =~ /s/oxms) {
802 0   0     0 while (@char and (not exists $tr{$char[0]})) {
803 0         0 shift @char;
804 0         0 $tr++;
805             }
806             }
807             }
808             else {
809 0         0 $replaced .= $char;
810             }
811             }
812             }
813             else {
814 0         0 while (defined(my $char = shift @char)) {
815 0 0       0 if (exists $tr{$char}) {
816 0         0 $replaced .= $tr{$char};
817 0         0 $tr++;
818 0 0       0 if ($modifier =~ /s/oxms) {
819 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
820 0         0 shift @char;
821 0         0 $tr++;
822             }
823             }
824             }
825             else {
826 0         0 $replaced .= $char;
827             }
828             }
829             }
830              
831 0 0       0 if ($modifier =~ /r/oxms) {
832 0         0 return $replaced;
833             }
834             else {
835 0         0 $_[0] = $replaced;
836 0 0       0 if ($bind_operator =~ / !~ /oxms) {
837 0         0 return not $tr;
838             }
839             else {
840 0         0 return $tr;
841             }
842             }
843             }
844              
845             #
846             # Latin-10 chop
847             #
848             sub Elatin10::chop(@) {
849              
850 0     0 0 0 my $chop;
851 0 0       0 if (@_ == 0) {
852 0         0 my @char = /\G (?>$q_char) /oxmsg;
853 0         0 $chop = pop @char;
854 0         0 $_ = join '', @char;
855             }
856             else {
857 0         0 for (@_) {
858 0         0 my @char = /\G (?>$q_char) /oxmsg;
859 0         0 $chop = pop @char;
860 0         0 $_ = join '', @char;
861             }
862             }
863 0         0 return $chop;
864             }
865              
866             #
867             # Latin-10 index by octet
868             #
869             sub Elatin10::index($$;$) {
870              
871 0     0 1 0 my($str,$substr,$position) = @_;
872 0   0     0 $position ||= 0;
873 0         0 my $pos = 0;
874              
875 0         0 while ($pos < CORE::length($str)) {
876 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
877 0 0       0 if ($pos >= $position) {
878 0         0 return $pos;
879             }
880             }
881 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
882 0         0 $pos += CORE::length($1);
883             }
884             else {
885 0         0 $pos += 1;
886             }
887             }
888 0         0 return -1;
889             }
890              
891             #
892             # Latin-10 reverse index
893             #
894             sub Elatin10::rindex($$;$) {
895              
896 0     0 0 0 my($str,$substr,$position) = @_;
897 0   0     0 $position ||= CORE::length($str) - 1;
898 0         0 my $pos = 0;
899 0         0 my $rindex = -1;
900              
901 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
902 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
903 0         0 $rindex = $pos;
904             }
905 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
906 0         0 $pos += CORE::length($1);
907             }
908             else {
909 0         0 $pos += 1;
910             }
911             }
912 0         0 return $rindex;
913             }
914              
915             #
916             # Latin-10 lower case first with parameter
917             #
918             sub Elatin10::lcfirst(@) {
919 0 0   0 0 0 if (@_) {
920 0         0 my $s = shift @_;
921 0 0 0     0 if (@_ and wantarray) {
922 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
923             }
924             else {
925 0         0 return Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
926             }
927             }
928             else {
929 0         0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
930             }
931             }
932              
933             #
934             # Latin-10 lower case first without parameter
935             #
936             sub Elatin10::lcfirst_() {
937 0     0 0 0 return Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
938             }
939              
940             #
941             # Latin-10 lower case with parameter
942             #
943             sub Elatin10::lc(@) {
944 0 0   0 0 0 if (@_) {
945 0         0 my $s = shift @_;
946 0 0 0     0 if (@_ and wantarray) {
947 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
948             }
949             else {
950 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
951             }
952             }
953             else {
954 0         0 return Elatin10::lc_();
955             }
956             }
957              
958             #
959             # Latin-10 lower case without parameter
960             #
961             sub Elatin10::lc_() {
962 0     0 0 0 my $s = $_;
963 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
964             }
965              
966             #
967             # Latin-10 upper case first with parameter
968             #
969             sub Elatin10::ucfirst(@) {
970 0 0   0 0 0 if (@_) {
971 0         0 my $s = shift @_;
972 0 0 0     0 if (@_ and wantarray) {
973 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
974             }
975             else {
976 0         0 return Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
977             }
978             }
979             else {
980 0         0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
981             }
982             }
983              
984             #
985             # Latin-10 upper case first without parameter
986             #
987             sub Elatin10::ucfirst_() {
988 0     0 0 0 return Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
989             }
990              
991             #
992             # Latin-10 upper case with parameter
993             #
994             sub Elatin10::uc(@) {
995 0 50   174 0 0 if (@_) {
996 174         260 my $s = shift @_;
997 174 50 33     216 if (@_ and wantarray) {
998 174 0       336 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
999             }
1000             else {
1001 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         530  
1002             }
1003             }
1004             else {
1005 174         634 return Elatin10::uc_();
1006             }
1007             }
1008              
1009             #
1010             # Latin-10 upper case without parameter
1011             #
1012             sub Elatin10::uc_() {
1013 0     0 0 0 my $s = $_;
1014 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1015             }
1016              
1017             #
1018             # Latin-10 fold case with parameter
1019             #
1020             sub Elatin10::fc(@) {
1021 0 50   197 0 0 if (@_) {
1022 197         278 my $s = shift @_;
1023 197 50 33     226 if (@_ and wantarray) {
1024 197 0       332 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1025             }
1026             else {
1027 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         476  
1028             }
1029             }
1030             else {
1031 197         1019 return Elatin10::fc_();
1032             }
1033             }
1034              
1035             #
1036             # Latin-10 fold case without parameter
1037             #
1038             sub Elatin10::fc_() {
1039 0     0 0 0 my $s = $_;
1040 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1041             }
1042              
1043             #
1044             # Latin-10 regexp capture
1045             #
1046             {
1047             sub Elatin10::capture {
1048 0     0 1 0 return $_[0];
1049             }
1050             }
1051              
1052             #
1053             # Latin-10 regexp ignore case modifier
1054             #
1055             sub Elatin10::ignorecase {
1056              
1057 0     0 0 0 my @string = @_;
1058 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1059              
1060             # ignore case of $scalar or @array
1061 0         0 for my $string (@string) {
1062              
1063             # split regexp
1064 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1065              
1066             # unescape character
1067 0         0 for (my $i=0; $i <= $#char; $i++) {
1068 0 0       0 next if not defined $char[$i];
1069              
1070             # open character class [...]
1071 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1072 0         0 my $left = $i;
1073              
1074             # [] make die "unmatched [] in regexp ...\n"
1075              
1076 0 0       0 if ($char[$i+1] eq ']') {
1077 0         0 $i++;
1078             }
1079              
1080 0         0 while (1) {
1081 0 0       0 if (++$i > $#char) {
1082 0         0 croak "Unmatched [] in regexp";
1083             }
1084 0 0       0 if ($char[$i] eq ']') {
1085 0         0 my $right = $i;
1086 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1087              
1088             # escape character
1089 0         0 for my $char (@charlist) {
1090 0 0       0 if (0) {
1091             }
1092              
1093 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1094 0         0 $char = '\\' . $char;
1095             }
1096             }
1097              
1098             # [...]
1099 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1100              
1101 0         0 $i = $left;
1102 0         0 last;
1103             }
1104             }
1105             }
1106              
1107             # open character class [^...]
1108             elsif ($char[$i] eq '[^') {
1109 0         0 my $left = $i;
1110              
1111             # [^] make die "unmatched [] in regexp ...\n"
1112              
1113 0 0       0 if ($char[$i+1] eq ']') {
1114 0         0 $i++;
1115             }
1116              
1117 0         0 while (1) {
1118 0 0       0 if (++$i > $#char) {
1119 0         0 croak "Unmatched [] in regexp";
1120             }
1121 0 0       0 if ($char[$i] eq ']') {
1122 0         0 my $right = $i;
1123 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1124              
1125             # escape character
1126 0         0 for my $char (@charlist) {
1127 0 0       0 if (0) {
1128             }
1129              
1130 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1131 0         0 $char = '\\' . $char;
1132             }
1133             }
1134              
1135             # [^...]
1136 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1137              
1138 0         0 $i = $left;
1139 0         0 last;
1140             }
1141             }
1142             }
1143              
1144             # rewrite classic character class or escape character
1145             elsif (my $char = classic_character_class($char[$i])) {
1146 0         0 $char[$i] = $char;
1147             }
1148              
1149             # with /i modifier
1150             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1151 0         0 my $uc = Elatin10::uc($char[$i]);
1152 0         0 my $fc = Elatin10::fc($char[$i]);
1153 0 0       0 if ($uc ne $fc) {
1154 0 0       0 if (CORE::length($fc) == 1) {
1155 0         0 $char[$i] = '[' . $uc . $fc . ']';
1156             }
1157             else {
1158 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1159             }
1160             }
1161             }
1162             }
1163              
1164             # characterize
1165 0         0 for (my $i=0; $i <= $#char; $i++) {
1166 0 0       0 next if not defined $char[$i];
1167              
1168 0 0       0 if (0) {
1169             }
1170              
1171             # quote character before ? + * {
1172 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1173 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1174 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1175             }
1176             }
1177             }
1178              
1179 0         0 $string = join '', @char;
1180             }
1181              
1182             # make regexp string
1183 0         0 return @string;
1184             }
1185              
1186             #
1187             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1188             #
1189             sub Elatin10::classic_character_class {
1190 0     1867 0 0 my($char) = @_;
1191              
1192             return {
1193             '\D' => '${Elatin10::eD}',
1194             '\S' => '${Elatin10::eS}',
1195             '\W' => '${Elatin10::eW}',
1196             '\d' => '[0-9]',
1197              
1198             # Before Perl 5.6, \s only matched the five whitespace characters
1199             # tab, newline, form-feed, carriage return, and the space character
1200             # itself, which, taken together, is the character class [\t\n\f\r ].
1201              
1202             # Vertical tabs are now whitespace
1203             # \s in a regex now matches a vertical tab in all circumstances.
1204             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1205             # \t \n \v \f \r space
1206             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1207             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1208             '\s' => '\s',
1209              
1210             '\w' => '[0-9A-Z_a-z]',
1211             '\C' => '[\x00-\xFF]',
1212             '\X' => 'X',
1213              
1214             # \h \v \H \V
1215              
1216             # P.114 Character Class Shortcuts
1217             # in Chapter 7: In the World of Regular Expressions
1218             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1219              
1220             # P.357 13.2.3 Whitespace
1221             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1222             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1223             #
1224             # 0x00009 CHARACTER TABULATION h s
1225             # 0x0000a LINE FEED (LF) vs
1226             # 0x0000b LINE TABULATION v
1227             # 0x0000c FORM FEED (FF) vs
1228             # 0x0000d CARRIAGE RETURN (CR) vs
1229             # 0x00020 SPACE h s
1230              
1231             # P.196 Table 5-9. Alphanumeric regex metasymbols
1232             # in Chapter 5. Pattern Matching
1233             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1234              
1235             # (and so on)
1236              
1237             '\H' => '${Elatin10::eH}',
1238             '\V' => '${Elatin10::eV}',
1239             '\h' => '[\x09\x20]',
1240             '\v' => '[\x0A\x0B\x0C\x0D]',
1241             '\R' => '${Elatin10::eR}',
1242              
1243             # \N
1244             #
1245             # http://perldoc.perl.org/perlre.html
1246             # Character Classes and other Special Escapes
1247             # Any character but \n (experimental). Not affected by /s modifier
1248              
1249             '\N' => '${Elatin10::eN}',
1250              
1251             # \b \B
1252              
1253             # P.180 Boundaries: The \b and \B Assertions
1254             # in Chapter 5: Pattern Matching
1255             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1256              
1257             # P.219 Boundaries: The \b and \B Assertions
1258             # in Chapter 5: Pattern Matching
1259             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1260              
1261             # \b really means (?:(?<=\w)(?!\w)|(?
1262             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1263             '\b' => '${Elatin10::eb}',
1264              
1265             # \B really means (?:(?<=\w)(?=\w)|(?
1266             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1267             '\B' => '${Elatin10::eB}',
1268              
1269 1867   100     2551 }->{$char} || '';
1270             }
1271              
1272             #
1273             # prepare Latin-10 characters per length
1274             #
1275              
1276             # 1 octet characters
1277             my @chars1 = ();
1278             sub chars1 {
1279 1867 0   0 0 67634 if (@chars1) {
1280 0         0 return @chars1;
1281             }
1282 0 0       0 if (exists $range_tr{1}) {
1283 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1284 0         0 while (my @range = splice(@ranges,0,1)) {
1285 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1286 0         0 push @chars1, pack 'C', $oct0;
1287             }
1288             }
1289             }
1290 0         0 return @chars1;
1291             }
1292              
1293             # 2 octets characters
1294             my @chars2 = ();
1295             sub chars2 {
1296 0 0   0 0 0 if (@chars2) {
1297 0         0 return @chars2;
1298             }
1299 0 0       0 if (exists $range_tr{2}) {
1300 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1301 0         0 while (my @range = splice(@ranges,0,2)) {
1302 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1303 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1304 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1305             }
1306             }
1307             }
1308             }
1309 0         0 return @chars2;
1310             }
1311              
1312             # 3 octets characters
1313             my @chars3 = ();
1314             sub chars3 {
1315 0 0   0 0 0 if (@chars3) {
1316 0         0 return @chars3;
1317             }
1318 0 0       0 if (exists $range_tr{3}) {
1319 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1320 0         0 while (my @range = splice(@ranges,0,3)) {
1321 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1322 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1323 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1324 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1325             }
1326             }
1327             }
1328             }
1329             }
1330 0         0 return @chars3;
1331             }
1332              
1333             # 4 octets characters
1334             my @chars4 = ();
1335             sub chars4 {
1336 0 0   0 0 0 if (@chars4) {
1337 0         0 return @chars4;
1338             }
1339 0 0       0 if (exists $range_tr{4}) {
1340 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1341 0         0 while (my @range = splice(@ranges,0,4)) {
1342 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1343 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1344 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1345 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1346 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1347             }
1348             }
1349             }
1350             }
1351             }
1352             }
1353 0         0 return @chars4;
1354             }
1355              
1356             #
1357             # Latin-10 open character list for tr
1358             #
1359             sub _charlist_tr {
1360              
1361 0     0   0 local $_ = shift @_;
1362              
1363             # unescape character
1364 0         0 my @char = ();
1365 0         0 while (not /\G \z/oxmsgc) {
1366 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1367 0         0 push @char, '\-';
1368             }
1369             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1370 0         0 push @char, CORE::chr(oct $1);
1371             }
1372             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1373 0         0 push @char, CORE::chr(hex $1);
1374             }
1375             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1376 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1377             }
1378             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1379             push @char, {
1380             '\0' => "\0",
1381             '\n' => "\n",
1382             '\r' => "\r",
1383             '\t' => "\t",
1384             '\f' => "\f",
1385             '\b' => "\x08", # \b means backspace in character class
1386             '\a' => "\a",
1387             '\e' => "\e",
1388 0         0 }->{$1};
1389             }
1390             elsif (/\G \\ ($q_char) /oxmsgc) {
1391 0         0 push @char, $1;
1392             }
1393             elsif (/\G ($q_char) /oxmsgc) {
1394 0         0 push @char, $1;
1395             }
1396             }
1397              
1398             # join separated multiple-octet
1399 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1400              
1401             # unescape '-'
1402 0         0 my @i = ();
1403 0         0 for my $i (0 .. $#char) {
1404 0 0       0 if ($char[$i] eq '\-') {
    0          
1405 0         0 $char[$i] = '-';
1406             }
1407             elsif ($char[$i] eq '-') {
1408 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1409 0         0 push @i, $i;
1410             }
1411             }
1412             }
1413              
1414             # open character list (reverse for splice)
1415 0         0 for my $i (CORE::reverse @i) {
1416 0         0 my @range = ();
1417              
1418             # range error
1419 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1420 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1421             }
1422              
1423             # range of multiple-octet code
1424 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1425 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1426 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1427             }
1428             elsif (CORE::length($char[$i+1]) == 2) {
1429 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1430 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1431             }
1432             elsif (CORE::length($char[$i+1]) == 3) {
1433 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1434 0         0 push @range, chars2();
1435 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1436             }
1437             elsif (CORE::length($char[$i+1]) == 4) {
1438 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1439 0         0 push @range, chars2();
1440 0         0 push @range, chars3();
1441 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1442             }
1443             else {
1444 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1445             }
1446             }
1447             elsif (CORE::length($char[$i-1]) == 2) {
1448 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1449 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1450             }
1451             elsif (CORE::length($char[$i+1]) == 3) {
1452 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1453 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1454             }
1455             elsif (CORE::length($char[$i+1]) == 4) {
1456 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1457 0         0 push @range, chars3();
1458 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1459             }
1460             else {
1461 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1462             }
1463             }
1464             elsif (CORE::length($char[$i-1]) == 3) {
1465 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1466 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1467             }
1468             elsif (CORE::length($char[$i+1]) == 4) {
1469 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1470 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1471             }
1472             else {
1473 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1474             }
1475             }
1476             elsif (CORE::length($char[$i-1]) == 4) {
1477 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1478 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1479             }
1480             else {
1481 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1482             }
1483             }
1484             else {
1485 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1486             }
1487              
1488 0         0 splice @char, $i-1, 3, @range;
1489             }
1490              
1491 0         0 return @char;
1492             }
1493              
1494             #
1495             # Latin-10 open character class
1496             #
1497             sub _cc {
1498 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1499 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1500             }
1501             elsif (scalar(@_) == 1) {
1502 0         0 return sprintf('\x%02X',$_[0]);
1503             }
1504             elsif (scalar(@_) == 2) {
1505 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1506 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1507             }
1508             elsif ($_[0] == $_[1]) {
1509 0         0 return sprintf('\x%02X',$_[0]);
1510             }
1511             elsif (($_[0]+1) == $_[1]) {
1512 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1513             }
1514             else {
1515 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1516             }
1517             }
1518             else {
1519 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1520             }
1521             }
1522              
1523             #
1524             # Latin-10 octet range
1525             #
1526             sub _octets {
1527 0     182   0 my $length = shift @_;
1528              
1529 182 50       291 if ($length == 1) {
1530 182         466 my($a1) = unpack 'C', $_[0];
1531 182         501 my($z1) = unpack 'C', $_[1];
1532              
1533 182 50       349 if ($a1 > $z1) {
1534 182         340 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1535             }
1536              
1537 0 50       0 if ($a1 == $z1) {
    50          
1538 182         408 return sprintf('\x%02X',$a1);
1539             }
1540             elsif (($a1+1) == $z1) {
1541 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1542             }
1543             else {
1544 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1545             }
1546             }
1547             else {
1548 182         1090 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1549             }
1550             }
1551              
1552             #
1553             # Latin-10 range regexp
1554             #
1555             sub _range_regexp {
1556 0     182   0 my($length,$first,$last) = @_;
1557              
1558 182         372 my @range_regexp = ();
1559 182 50       222 if (not exists $range_tr{$length}) {
1560 182         449 return @range_regexp;
1561             }
1562              
1563 0         0 my @ranges = @{ $range_tr{$length} };
  182         260  
1564 182         367 while (my @range = splice(@ranges,0,$length)) {
1565 182         520 my $min = '';
1566 182         253 my $max = '';
1567 182         219 for (my $i=0; $i < $length; $i++) {
1568 182         431 $min .= pack 'C', $range[$i][0];
1569 182         570 $max .= pack 'C', $range[$i][-1];
1570             }
1571              
1572             # min___max
1573             # FIRST_____________LAST
1574             # (nothing)
1575              
1576 182 50 33     422 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1577             }
1578              
1579             # **********
1580             # min_________max
1581             # FIRST_____________LAST
1582             # **********
1583              
1584             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1585 182         1705 push @range_regexp, _octets($length,$first,$max,$min,$max);
1586             }
1587              
1588             # **********************
1589             # min________________max
1590             # FIRST_____________LAST
1591             # **********************
1592              
1593             elsif (($min eq $first) and ($max eq $last)) {
1594 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1595             }
1596              
1597             # *********
1598             # min___max
1599             # FIRST_____________LAST
1600             # *********
1601              
1602             elsif (($first le $min) and ($max le $last)) {
1603 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1604             }
1605              
1606             # **********************
1607             # min__________________________max
1608             # FIRST_____________LAST
1609             # **********************
1610              
1611             elsif (($min le $first) and ($last le $max)) {
1612 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1613             }
1614              
1615             # *********
1616             # min________max
1617             # FIRST_____________LAST
1618             # *********
1619              
1620             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1621 182         437 push @range_regexp, _octets($length,$min,$last,$min,$max);
1622             }
1623              
1624             # min___max
1625             # FIRST_____________LAST
1626             # (nothing)
1627              
1628             elsif ($last lt $min) {
1629             }
1630              
1631             else {
1632 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1633             }
1634             }
1635              
1636 0         0 return @range_regexp;
1637             }
1638              
1639             #
1640             # Latin-10 open character list for qr and not qr
1641             #
1642             sub _charlist {
1643              
1644 182     358   383 my $modifier = pop @_;
1645 358         717 my @char = @_;
1646              
1647 358 100       849 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1648              
1649             # unescape character
1650 358         878 for (my $i=0; $i <= $#char; $i++) {
1651              
1652             # escape - to ...
1653 358 100 100     1437 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1654 1125 100 100     8085 if ((0 < $i) and ($i < $#char)) {
1655 206         695 $char[$i] = '...';
1656             }
1657             }
1658              
1659             # octal escape sequence
1660             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1661 182         383 $char[$i] = octchr($1);
1662             }
1663              
1664             # hexadecimal escape sequence
1665             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1666 0         0 $char[$i] = hexchr($1);
1667             }
1668              
1669             # \b{...} --> b\{...}
1670             # \B{...} --> B\{...}
1671             # \N{CHARNAME} --> N\{CHARNAME}
1672             # \p{PROPERTY} --> p\{PROPERTY}
1673             # \P{PROPERTY} --> P\{PROPERTY}
1674             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1675 0         0 $char[$i] = $1 . '\\' . $2;
1676             }
1677              
1678             # \p, \P, \X --> p, P, X
1679             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1680 0         0 $char[$i] = $1;
1681             }
1682              
1683             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1684 0         0 $char[$i] = CORE::chr oct $1;
1685             }
1686             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1687 0         0 $char[$i] = CORE::chr hex $1;
1688             }
1689             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1690 22         97 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1691             }
1692             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1693             $char[$i] = {
1694             '\0' => "\0",
1695             '\n' => "\n",
1696             '\r' => "\r",
1697             '\t' => "\t",
1698             '\f' => "\f",
1699             '\b' => "\x08", # \b means backspace in character class
1700             '\a' => "\a",
1701             '\e' => "\e",
1702             '\d' => '[0-9]',
1703              
1704             # Vertical tabs are now whitespace
1705             # \s in a regex now matches a vertical tab in all circumstances.
1706             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1707             # \t \n \v \f \r space
1708             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1709             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1710             '\s' => '\s',
1711              
1712             '\w' => '[0-9A-Z_a-z]',
1713             '\D' => '${Elatin10::eD}',
1714             '\S' => '${Elatin10::eS}',
1715             '\W' => '${Elatin10::eW}',
1716              
1717             '\H' => '${Elatin10::eH}',
1718             '\V' => '${Elatin10::eV}',
1719             '\h' => '[\x09\x20]',
1720             '\v' => '[\x0A\x0B\x0C\x0D]',
1721             '\R' => '${Elatin10::eR}',
1722              
1723 0         0 }->{$1};
1724             }
1725              
1726             # POSIX-style character classes
1727             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1728             $char[$i] = {
1729              
1730             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1731             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1732             '[:^lower:]' => '${Elatin10::not_lower_i}',
1733             '[:^upper:]' => '${Elatin10::not_upper_i}',
1734              
1735 25         369 }->{$1};
1736             }
1737             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1738             $char[$i] = {
1739              
1740             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1741             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1742             '[:ascii:]' => '[\x00-\x7F]',
1743             '[:blank:]' => '[\x09\x20]',
1744             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1745             '[:digit:]' => '[\x30-\x39]',
1746             '[:graph:]' => '[\x21-\x7F]',
1747             '[:lower:]' => '[\x61-\x7A]',
1748             '[:print:]' => '[\x20-\x7F]',
1749             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1750              
1751             # P.174 POSIX-Style Character Classes
1752             # in Chapter 5: Pattern Matching
1753             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1754              
1755             # P.311 11.2.4 Character Classes and other Special Escapes
1756             # in Chapter 11: perlre: Perl regular expressions
1757             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1758              
1759             # P.210 POSIX-Style Character Classes
1760             # in Chapter 5: Pattern Matching
1761             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1762              
1763             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1764              
1765             '[:upper:]' => '[\x41-\x5A]',
1766             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1767             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1768             '[:^alnum:]' => '${Elatin10::not_alnum}',
1769             '[:^alpha:]' => '${Elatin10::not_alpha}',
1770             '[:^ascii:]' => '${Elatin10::not_ascii}',
1771             '[:^blank:]' => '${Elatin10::not_blank}',
1772             '[:^cntrl:]' => '${Elatin10::not_cntrl}',
1773             '[:^digit:]' => '${Elatin10::not_digit}',
1774             '[:^graph:]' => '${Elatin10::not_graph}',
1775             '[:^lower:]' => '${Elatin10::not_lower}',
1776             '[:^print:]' => '${Elatin10::not_print}',
1777             '[:^punct:]' => '${Elatin10::not_punct}',
1778             '[:^space:]' => '${Elatin10::not_space}',
1779             '[:^upper:]' => '${Elatin10::not_upper}',
1780             '[:^word:]' => '${Elatin10::not_word}',
1781             '[:^xdigit:]' => '${Elatin10::not_xdigit}',
1782              
1783 8         59 }->{$1};
1784             }
1785             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1786 70         1395 $char[$i] = $1;
1787             }
1788             }
1789              
1790             # open character list
1791 7         32 my @singleoctet = ();
1792 358         608 my @multipleoctet = ();
1793 358         458 for (my $i=0; $i <= $#char; ) {
1794              
1795             # escaped -
1796 358 100 100     765 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1797 943         3669 $i += 1;
1798 182         239 next;
1799             }
1800              
1801             # make range regexp
1802             elsif ($char[$i] eq '...') {
1803              
1804             # range error
1805 182 50       318 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1806 182         625 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1807             }
1808             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1809 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1810 182         462 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1811             }
1812             }
1813              
1814             # make range regexp per length
1815 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1816 182         517 my @regexp = ();
1817              
1818             # is first and last
1819 182 50 33     243 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1820 182         613 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1821             }
1822              
1823             # is first
1824             elsif ($length == CORE::length($char[$i-1])) {
1825 182         459 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1826             }
1827              
1828             # is inside in first and last
1829             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1830 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1831             }
1832              
1833             # is last
1834             elsif ($length == CORE::length($char[$i+1])) {
1835 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1836             }
1837              
1838             else {
1839 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1840             }
1841              
1842 0 50       0 if ($length == 1) {
1843 182         388 push @singleoctet, @regexp;
1844             }
1845             else {
1846 182         404 push @multipleoctet, @regexp;
1847             }
1848             }
1849              
1850 0         0 $i += 2;
1851             }
1852              
1853             # with /i modifier
1854             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1855 182 100       359 if ($modifier =~ /i/oxms) {
1856 493         815 my $uc = Elatin10::uc($char[$i]);
1857 24         52 my $fc = Elatin10::fc($char[$i]);
1858 24 100       49 if ($uc ne $fc) {
1859 24 50       46 if (CORE::length($fc) == 1) {
1860 12         26 push @singleoctet, $uc, $fc;
1861             }
1862             else {
1863 12         18 push @singleoctet, $uc;
1864 0         0 push @multipleoctet, $fc;
1865             }
1866             }
1867             else {
1868 0         0 push @singleoctet, $char[$i];
1869             }
1870             }
1871             else {
1872 12         22 push @singleoctet, $char[$i];
1873             }
1874 469         767 $i += 1;
1875             }
1876              
1877             # single character of single octet code
1878             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1879 493         807 push @singleoctet, "\t", "\x20";
1880 0         0 $i += 1;
1881             }
1882             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1883 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1884 0         0 $i += 1;
1885             }
1886             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1887 0         0 push @singleoctet, $char[$i];
1888 2         5 $i += 1;
1889             }
1890              
1891             # single character of multiple-octet code
1892             else {
1893 2         6 push @multipleoctet, $char[$i];
1894 84         164 $i += 1;
1895             }
1896             }
1897              
1898             # quote metachar
1899 84         154 for (@singleoctet) {
1900 358 50       702 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1901 689         3113 $_ = '-';
1902             }
1903             elsif (/\A \n \z/oxms) {
1904 0         0 $_ = '\n';
1905             }
1906             elsif (/\A \r \z/oxms) {
1907 8         14 $_ = '\r';
1908             }
1909             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1910 8         23 $_ = sprintf('\x%02X', CORE::ord $1);
1911             }
1912             elsif (/\A [\x00-\xFF] \z/oxms) {
1913 60         192 $_ = quotemeta $_;
1914             }
1915             }
1916              
1917             # return character list
1918 429         640 return \@singleoctet, \@multipleoctet;
1919             }
1920              
1921             #
1922             # Latin-10 octal escape sequence
1923             #
1924             sub octchr {
1925 358     5 0 1184 my($octdigit) = @_;
1926              
1927 5         14 my @binary = ();
1928 5         10 for my $octal (split(//,$octdigit)) {
1929             push @binary, {
1930             '0' => '000',
1931             '1' => '001',
1932             '2' => '010',
1933             '3' => '011',
1934             '4' => '100',
1935             '5' => '101',
1936             '6' => '110',
1937             '7' => '111',
1938 5         38 }->{$octal};
1939             }
1940 50         180 my $binary = join '', @binary;
1941              
1942             my $octchr = {
1943             # 1234567
1944             1 => pack('B*', "0000000$binary"),
1945             2 => pack('B*', "000000$binary"),
1946             3 => pack('B*', "00000$binary"),
1947             4 => pack('B*', "0000$binary"),
1948             5 => pack('B*', "000$binary"),
1949             6 => pack('B*', "00$binary"),
1950             7 => pack('B*', "0$binary"),
1951             0 => pack('B*', "$binary"),
1952              
1953 5         15 }->{CORE::length($binary) % 8};
1954              
1955 5         61 return $octchr;
1956             }
1957              
1958             #
1959             # Latin-10 hexadecimal escape sequence
1960             #
1961             sub hexchr {
1962 5     5 0 20 my($hexdigit) = @_;
1963              
1964             my $hexchr = {
1965             1 => pack('H*', "0$hexdigit"),
1966             0 => pack('H*', "$hexdigit"),
1967              
1968 5         14 }->{CORE::length($_[0]) % 2};
1969              
1970 5         43 return $hexchr;
1971             }
1972              
1973             #
1974             # Latin-10 open character list for qr
1975             #
1976             sub charlist_qr {
1977              
1978 5     314 0 18 my $modifier = pop @_;
1979 314         620 my @char = @_;
1980              
1981 314         725 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1982 314         918 my @singleoctet = @$singleoctet;
1983 314         640 my @multipleoctet = @$multipleoctet;
1984              
1985             # return character list
1986 314 100       455 if (scalar(@singleoctet) >= 1) {
1987              
1988             # with /i modifier
1989 314 100       657 if ($modifier =~ m/i/oxms) {
1990 236         488 my %singleoctet_ignorecase = ();
1991 22         30 for (@singleoctet) {
1992 22   100     39 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1993 46         223 for my $ord (hex($1) .. hex($2)) {
1994 46         166 my $char = CORE::chr($ord);
1995 66         96 my $uc = Elatin10::uc($char);
1996 66         99 my $fc = Elatin10::fc($char);
1997 66 100       104 if ($uc eq $fc) {
1998 66         106 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1999             }
2000             else {
2001 12 50       83 if (CORE::length($fc) == 1) {
2002 54         75 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2003 54         112 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2004             }
2005             else {
2006 54         193 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2007 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2008             }
2009             }
2010             }
2011             }
2012 0 50       0 if ($_ ne '') {
2013 46         92 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2014             }
2015             }
2016 0         0 my $i = 0;
2017 22         42 my @singleoctet_ignorecase = ();
2018 22         35 for my $ord (0 .. 255) {
2019 22 100       37 if (exists $singleoctet_ignorecase{$ord}) {
2020 5632         6468 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         89  
2021             }
2022             else {
2023 96         199 $i++;
2024             }
2025             }
2026 5536         5366 @singleoctet = ();
2027 22         37 for my $range (@singleoctet_ignorecase) {
2028 22 100       63 if (ref $range) {
2029 3648 100       5568 if (scalar(@{$range}) == 1) {
  56 50       56  
2030 56         93 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         37  
2031             }
2032 36         126 elsif (scalar(@{$range}) == 2) {
2033 20         25 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2034             }
2035             else {
2036 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         24  
2037             }
2038             }
2039             }
2040             }
2041              
2042 20         87 my $not_anchor = '';
2043              
2044 236         343 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2045             }
2046 236 100       601 if (scalar(@multipleoctet) >= 2) {
2047 314         657 return '(?:' . join('|', @multipleoctet) . ')';
2048             }
2049             else {
2050 6         32 return $multipleoctet[0];
2051             }
2052             }
2053              
2054             #
2055             # Latin-10 open character list for not qr
2056             #
2057             sub charlist_not_qr {
2058              
2059 308     44 0 1246 my $modifier = pop @_;
2060 44         82 my @char = @_;
2061              
2062 44         97 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2063 44         117 my @singleoctet = @$singleoctet;
2064 44         96 my @multipleoctet = @$multipleoctet;
2065              
2066             # with /i modifier
2067 44 100       64 if ($modifier =~ m/i/oxms) {
2068 44         106 my %singleoctet_ignorecase = ();
2069 10         13 for (@singleoctet) {
2070 10   66     19 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2071 10         50 for my $ord (hex($1) .. hex($2)) {
2072 10         32 my $char = CORE::chr($ord);
2073 30         52 my $uc = Elatin10::uc($char);
2074 30         47 my $fc = Elatin10::fc($char);
2075 30 50       49 if ($uc eq $fc) {
2076 30         67 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2077             }
2078             else {
2079 0 50       0 if (CORE::length($fc) == 1) {
2080 30         50 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2081 30         62 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2082             }
2083             else {
2084 30         102 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2085 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2086             }
2087             }
2088             }
2089             }
2090 0 50       0 if ($_ ne '') {
2091 10         24 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2092             }
2093             }
2094 0         0 my $i = 0;
2095 10         11 my @singleoctet_ignorecase = ();
2096 10         15 for my $ord (0 .. 255) {
2097 10 100       14 if (exists $singleoctet_ignorecase{$ord}) {
2098 2560         2916 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         51  
2099             }
2100             else {
2101 60         109 $i++;
2102             }
2103             }
2104 2500         2464 @singleoctet = ();
2105 10         13 for my $range (@singleoctet_ignorecase) {
2106 10 100       22 if (ref $range) {
2107 960 50       1429 if (scalar(@{$range}) == 1) {
  20 50       22  
2108 20         31 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2109             }
2110 0         0 elsif (scalar(@{$range}) == 2) {
2111 20         24 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2112             }
2113             else {
2114 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         23  
2115             }
2116             }
2117             }
2118             }
2119              
2120             # return character list
2121 20 50       75 if (scalar(@multipleoctet) >= 1) {
2122 44 0       96 if (scalar(@singleoctet) >= 1) {
2123              
2124             # any character other than multiple-octet and single octet character class
2125 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2126             }
2127             else {
2128              
2129             # any character other than multiple-octet character class
2130 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2131             }
2132             }
2133             else {
2134 0 50       0 if (scalar(@singleoctet) >= 1) {
2135              
2136             # any character other than single octet character class
2137 44         130 return '(?:[^' . join('', @singleoctet) . '])';
2138             }
2139             else {
2140              
2141             # any character
2142 44         274 return "(?:$your_char)";
2143             }
2144             }
2145             }
2146              
2147             #
2148             # open file in read mode
2149             #
2150             sub _open_r {
2151 0     412   0 my(undef,$file) = @_;
2152 206     206   2311 use Fcntl qw(O_RDONLY);
  206         20829  
  206         44628  
2153 412         1201 return CORE::sysopen($_[0], $file, &O_RDONLY);
2154             }
2155              
2156             #
2157             # open file in append mode
2158             #
2159             sub _open_a {
2160 412     206   27700 my(undef,$file) = @_;
2161 206     206   1438 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  206         1432  
  206         695827  
2162 206         675 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2163             }
2164              
2165             #
2166             # safe system
2167             #
2168             sub _systemx {
2169              
2170             # P.707 29.2.33. exec
2171             # in Chapter 29: Functions
2172             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2173             #
2174             # Be aware that in older releases of Perl, exec (and system) did not flush
2175             # your output buffer, so you needed to enable command buffering by setting $|
2176             # on one or more filehandles to avoid lost output in the case of exec, or
2177             # misordererd output in the case of system. This situation was largely remedied
2178             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2179              
2180             # P.855 exec
2181             # in Chapter 27: Functions
2182             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2183             #
2184             # In very old release of Perl (before v5.6), exec (and system) did not flush
2185             # your output buffer, so you needed to enable command buffering by setting $|
2186             # on one or more filehandles to avoid lost output with exec or misordered
2187             # output with system.
2188              
2189 206     206   54907 $| = 1;
2190              
2191             # P.565 23.1.2. Cleaning Up Your Environment
2192             # in Chapter 23: Security
2193             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2194              
2195             # P.656 Cleaning Up Your Environment
2196             # in Chapter 20: Security
2197             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2198              
2199             # local $ENV{'PATH'} = '.';
2200 206         992 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2201              
2202             # P.707 29.2.33. exec
2203             # in Chapter 29: Functions
2204             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2205             #
2206             # As we mentioned earlier, exec treats a discrete list of arguments as an
2207             # indication that it should bypass shell processing. However, there is one
2208             # place where you might still get tripped up. The exec call (and system, too)
2209             # will not distinguish between a single scalar argument and an array containing
2210             # only one element.
2211             #
2212             # @args = ("echo surprise"); # just one element in list
2213             # exec @args # still subject to shell escapes
2214             # or die "exec: $!"; # because @args == 1
2215             #
2216             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2217             # first argument as the pathname, which forces the rest of the arguments to be
2218             # interpreted as a list, even if there is only one of them:
2219             #
2220             # exec { $args[0] } @args # safe even with one-argument list
2221             # or die "can't exec @args: $!";
2222              
2223             # P.855 exec
2224             # in Chapter 27: Functions
2225             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2226             #
2227             # As we mentioned earlier, exec treats a discrete list of arguments as a
2228             # directive to bypass shell processing. However, there is one place where
2229             # you might still get tripped up. The exec call (and system, too) cannot
2230             # distinguish between a single scalar argument and an array containing
2231             # only one element.
2232             #
2233             # @args = ("echo surprise"); # just one element in list
2234             # exec @args # still subject to shell escapes
2235             # || die "exec: $!"; # because @args == 1
2236             #
2237             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2238             # argument as the pathname, which forces the rest of the arguments to be
2239             # interpreted as a list, even if there is only one of them:
2240             #
2241             # exec { $args[0] } @args # safe even with one-argument list
2242             # || die "can't exec @args: $!";
2243              
2244 206         2176 return CORE::system { $_[0] } @_; # safe even with one-argument list
  206         449  
2245             }
2246              
2247             #
2248             # Latin-10 order to character (with parameter)
2249             #
2250             sub Elatin10::chr(;$) {
2251              
2252 206 0   0 0 18532132 my $c = @_ ? $_[0] : $_;
2253              
2254 0 0       0 if ($c == 0x00) {
2255 0         0 return "\x00";
2256             }
2257             else {
2258 0         0 my @chr = ();
2259 0         0 while ($c > 0) {
2260 0         0 unshift @chr, ($c % 0x100);
2261 0         0 $c = int($c / 0x100);
2262             }
2263 0         0 return pack 'C*', @chr;
2264             }
2265             }
2266              
2267             #
2268             # Latin-10 order to character (without parameter)
2269             #
2270             sub Elatin10::chr_() {
2271              
2272 0     0 0 0 my $c = $_;
2273              
2274 0 0       0 if ($c == 0x00) {
2275 0         0 return "\x00";
2276             }
2277             else {
2278 0         0 my @chr = ();
2279 0         0 while ($c > 0) {
2280 0         0 unshift @chr, ($c % 0x100);
2281 0         0 $c = int($c / 0x100);
2282             }
2283 0         0 return pack 'C*', @chr;
2284             }
2285             }
2286              
2287             #
2288             # Latin-10 path globbing (with parameter)
2289             #
2290             sub Elatin10::glob($) {
2291              
2292 0 0   0 0 0 if (wantarray) {
2293 0         0 my @glob = _DOS_like_glob(@_);
2294 0         0 for my $glob (@glob) {
2295 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2296             }
2297 0         0 return @glob;
2298             }
2299             else {
2300 0         0 my $glob = _DOS_like_glob(@_);
2301 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2302 0         0 return $glob;
2303             }
2304             }
2305              
2306             #
2307             # Latin-10 path globbing (without parameter)
2308             #
2309             sub Elatin10::glob_() {
2310              
2311 0 0   0 0 0 if (wantarray) {
2312 0         0 my @glob = _DOS_like_glob();
2313 0         0 for my $glob (@glob) {
2314 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2315             }
2316 0         0 return @glob;
2317             }
2318             else {
2319 0         0 my $glob = _DOS_like_glob();
2320 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2321 0         0 return $glob;
2322             }
2323             }
2324              
2325             #
2326             # Latin-10 path globbing via File::DosGlob 1.10
2327             #
2328             # Often I confuse "_dosglob" and "_doglob".
2329             # So, I renamed "_dosglob" to "_DOS_like_glob".
2330             #
2331             my %iter;
2332             my %entries;
2333             sub _DOS_like_glob {
2334              
2335             # context (keyed by second cxix argument provided by core)
2336 0     0   0 my($expr,$cxix) = @_;
2337              
2338             # glob without args defaults to $_
2339 0 0       0 $expr = $_ if not defined $expr;
2340              
2341             # represents the current user's home directory
2342             #
2343             # 7.3. Expanding Tildes in Filenames
2344             # in Chapter 7. File Access
2345             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2346             #
2347             # and File::HomeDir, File::HomeDir::Windows module
2348              
2349             # DOS-like system
2350 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2351 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2352             { my_home_MSWin32() }oxmse;
2353             }
2354              
2355             # UNIX-like system
2356 0 0 0     0 else {
  0         0  
2357             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2358             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2359             }
2360 0 0       0  
2361 0 0       0 # assume global context if not provided one
2362             $cxix = '_G_' if not defined $cxix;
2363             $iter{$cxix} = 0 if not exists $iter{$cxix};
2364 0 0       0  
2365 0         0 # if we're just beginning, do it all first
2366             if ($iter{$cxix} == 0) {
2367             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2368             }
2369 0 0       0  
2370 0         0 # chuck it all out, quick or slow
2371 0         0 if (wantarray) {
  0         0  
2372             delete $iter{$cxix};
2373             return @{delete $entries{$cxix}};
2374 0 0       0 }
  0         0  
2375 0         0 else {
  0         0  
2376             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2377             return shift @{$entries{$cxix}};
2378             }
2379 0         0 else {
2380 0         0 # return undef for EOL
2381 0         0 delete $iter{$cxix};
2382             delete $entries{$cxix};
2383             return undef;
2384             }
2385             }
2386             }
2387              
2388             #
2389             # Latin-10 path globbing subroutine
2390             #
2391 0     0   0 sub _do_glob {
2392 0         0  
2393 0         0 my($cond,@expr) = @_;
2394             my @glob = ();
2395             my $fix_drive_relative_paths = 0;
2396 0         0  
2397 0 0       0 OUTER:
2398 0 0       0 for my $expr (@expr) {
2399             next OUTER if not defined $expr;
2400 0         0 next OUTER if $expr eq '';
2401 0         0  
2402 0         0 my @matched = ();
2403 0         0 my @globdir = ();
2404 0         0 my $head = '.';
2405             my $pathsep = '/';
2406             my $tail;
2407 0 0       0  
2408 0         0 # if argument is within quotes strip em and do no globbing
2409 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2410 0 0       0 $expr = $1;
2411 0         0 if ($cond eq 'd') {
2412             if (-d $expr) {
2413             push @glob, $expr;
2414             }
2415 0 0       0 }
2416 0         0 else {
2417             if (-e $expr) {
2418             push @glob, $expr;
2419 0         0 }
2420             }
2421             next OUTER;
2422             }
2423              
2424 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2425 0 0       0 # to h:./*.pm to expand correctly
2426 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2427             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2428             $fix_drive_relative_paths = 1;
2429             }
2430 0 0       0 }
2431 0 0       0  
2432 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2433 0         0 if ($tail eq '') {
2434             push @glob, $expr;
2435 0 0       0 next OUTER;
2436 0 0       0 }
2437 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2438 0         0 if (@globdir = _do_glob('d', $head)) {
2439             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2440             next OUTER;
2441 0 0 0     0 }
2442 0         0 }
2443             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2444 0         0 $head .= $pathsep;
2445             }
2446             $expr = $tail;
2447             }
2448 0 0       0  
2449 0 0       0 # If file component has no wildcards, we can avoid opendir
2450 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2451             if ($head eq '.') {
2452 0 0 0     0 $head = '';
2453 0         0 }
2454             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2455 0         0 $head .= $pathsep;
2456 0 0       0 }
2457 0 0       0 $head .= $expr;
2458 0         0 if ($cond eq 'd') {
2459             if (-d $head) {
2460             push @glob, $head;
2461             }
2462 0 0       0 }
2463 0         0 else {
2464             if (-e $head) {
2465             push @glob, $head;
2466 0         0 }
2467             }
2468 0 0       0 next OUTER;
2469 0         0 }
2470 0         0 opendir(*DIR, $head) or next OUTER;
2471             my @leaf = readdir DIR;
2472 0 0       0 closedir DIR;
2473 0         0  
2474             if ($head eq '.') {
2475 0 0 0     0 $head = '';
2476 0         0 }
2477             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2478             $head .= $pathsep;
2479 0         0 }
2480 0         0  
2481 0         0 my $pattern = '';
2482             while ($expr =~ / \G ($q_char) /oxgc) {
2483             my $char = $1;
2484              
2485             # 6.9. Matching Shell Globs as Regular Expressions
2486             # in Chapter 6. Pattern Matching
2487             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2488 0 0       0 # (and so on)
    0          
    0          
2489 0         0  
2490             if ($char eq '*') {
2491             $pattern .= "(?:$your_char)*",
2492 0         0 }
2493             elsif ($char eq '?') {
2494             $pattern .= "(?:$your_char)?", # DOS style
2495             # $pattern .= "(?:$your_char)", # UNIX style
2496 0         0 }
2497             elsif ((my $fc = Elatin10::fc($char)) ne $char) {
2498             $pattern .= $fc;
2499 0         0 }
2500             else {
2501             $pattern .= quotemeta $char;
2502 0     0   0 }
  0         0  
2503             }
2504             my $matchsub = sub { Elatin10::fc($_[0]) =~ /\A $pattern \z/xms };
2505              
2506             # if ($@) {
2507             # print STDERR "$0: $@\n";
2508             # next OUTER;
2509             # }
2510 0         0  
2511 0 0 0     0 INNER:
2512 0         0 for my $leaf (@leaf) {
2513             if ($leaf eq '.' or $leaf eq '..') {
2514 0 0 0     0 next INNER;
2515 0         0 }
2516             if ($cond eq 'd' and not -d "$head$leaf") {
2517             next INNER;
2518 0 0       0 }
2519 0         0  
2520 0         0 if (&$matchsub($leaf)) {
2521             push @matched, "$head$leaf";
2522             next INNER;
2523             }
2524              
2525             # [DOS compatibility special case]
2526 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2527              
2528             if (Elatin10::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2529             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2530 0 0       0 Elatin10::index($pattern,'\\.') != -1 # pattern has a dot.
2531 0         0 ) {
2532 0         0 if (&$matchsub("$leaf.")) {
2533             push @matched, "$head$leaf";
2534             next INNER;
2535             }
2536 0 0       0 }
2537 0         0 }
2538             if (@matched) {
2539             push @glob, @matched;
2540 0 0       0 }
2541 0         0 }
2542 0         0 if ($fix_drive_relative_paths) {
2543             for my $glob (@glob) {
2544             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2545 0         0 }
2546             }
2547             return @glob;
2548             }
2549              
2550             #
2551             # Latin-10 parse line
2552             #
2553 0     0   0 sub _parse_line {
2554              
2555 0         0 my($line) = @_;
2556 0         0  
2557 0         0 $line .= ' ';
2558             my @piece = ();
2559             while ($line =~ /
2560             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2561             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2562 0 0       0 /oxmsg
2563             ) {
2564 0         0 push @piece, defined($1) ? $1 : $2;
2565             }
2566             return @piece;
2567             }
2568              
2569             #
2570             # Latin-10 parse path
2571             #
2572 0     0   0 sub _parse_path {
2573              
2574 0         0 my($path,$pathsep) = @_;
2575 0         0  
2576 0         0 $path .= '/';
2577             my @subpath = ();
2578             while ($path =~ /
2579             ((?: [^\/\\] )+?) [\/\\]
2580 0         0 /oxmsg
2581             ) {
2582             push @subpath, $1;
2583 0         0 }
2584 0         0  
2585 0         0 my $tail = pop @subpath;
2586             my $head = join $pathsep, @subpath;
2587             return $head, $tail;
2588             }
2589              
2590             #
2591             # via File::HomeDir::Windows 1.00
2592             #
2593             sub my_home_MSWin32 {
2594              
2595             # A lot of unix people and unix-derived tools rely on
2596 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2597 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2598             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2599             return $ENV{'HOME'};
2600             }
2601              
2602 0         0 # Do we have a user profile?
2603             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2604             return $ENV{'USERPROFILE'};
2605             }
2606              
2607 0         0 # Some Windows use something like $ENV{'HOME'}
2608             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2609             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2610 0         0 }
2611              
2612             return undef;
2613             }
2614              
2615             #
2616             # via File::HomeDir::Unix 1.00
2617 0     0 0 0 #
2618             sub my_home {
2619 0 0 0     0 my $home;
    0 0        
2620 0         0  
2621             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2622             $home = $ENV{'HOME'};
2623             }
2624              
2625             # This is from the original code, but I'm guessing
2626 0         0 # it means "login directory" and exists on some Unixes.
2627             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2628             $home = $ENV{'LOGDIR'};
2629             }
2630              
2631             ### More-desperate methods
2632              
2633 0         0 # Light desperation on any (Unixish) platform
2634             else {
2635             $home = CORE::eval q{ (getpwuid($<))[7] };
2636             }
2637              
2638 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2639 0         0 # For example, "nobody"-like users might use /nonexistant
2640             if (defined $home and ! -d($home)) {
2641 0         0 $home = undef;
2642             }
2643             return $home;
2644             }
2645              
2646             #
2647             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2648 0     0 0 0 #
2649             sub Elatin10::PREMATCH {
2650             return $`;
2651             }
2652              
2653             #
2654             # ${^MATCH}, $MATCH, $& the string that matched
2655 0     0 0 0 #
2656             sub Elatin10::MATCH {
2657             return $&;
2658             }
2659              
2660             #
2661             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2662 0     0 0 0 #
2663             sub Elatin10::POSTMATCH {
2664             return $';
2665             }
2666              
2667             #
2668             # Latin-10 character to order (with parameter)
2669             #
2670 0 0   0 1 0 sub Latin10::ord(;$) {
2671              
2672 0 0       0 local $_ = shift if @_;
2673 0         0  
2674 0         0 if (/\A ($q_char) /oxms) {
2675 0         0 my @ord = unpack 'C*', $1;
2676 0         0 my $ord = 0;
2677             while (my $o = shift @ord) {
2678 0         0 $ord = $ord * 0x100 + $o;
2679             }
2680             return $ord;
2681 0         0 }
2682             else {
2683             return CORE::ord $_;
2684             }
2685             }
2686              
2687             #
2688             # Latin-10 character to order (without parameter)
2689             #
2690 0 0   0 0 0 sub Latin10::ord_() {
2691 0         0  
2692 0         0 if (/\A ($q_char) /oxms) {
2693 0         0 my @ord = unpack 'C*', $1;
2694 0         0 my $ord = 0;
2695             while (my $o = shift @ord) {
2696 0         0 $ord = $ord * 0x100 + $o;
2697             }
2698             return $ord;
2699 0         0 }
2700             else {
2701             return CORE::ord $_;
2702             }
2703             }
2704              
2705             #
2706             # Latin-10 reverse
2707             #
2708 0 0   0 0 0 sub Latin10::reverse(@) {
2709 0         0  
2710             if (wantarray) {
2711             return CORE::reverse @_;
2712             }
2713             else {
2714              
2715             # One of us once cornered Larry in an elevator and asked him what
2716             # problem he was solving with this, but he looked as far off into
2717             # the distance as he could in an elevator and said, "It seemed like
2718 0         0 # a good idea at the time."
2719              
2720             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2721             }
2722             }
2723              
2724             #
2725             # Latin-10 getc (with parameter, without parameter)
2726             #
2727 0     0 0 0 sub Latin10::getc(;*@) {
2728 0 0       0  
2729 0 0 0     0 my($package) = caller;
2730             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2731 0         0 croak 'Too many arguments for Latin10::getc' if @_ and not wantarray;
  0         0  
2732 0         0  
2733 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2734 0         0 my $getc = '';
2735 0 0       0 for my $length ($length[0] .. $length[-1]) {
2736 0 0       0 $getc .= CORE::getc($fh);
2737 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2738             if ($getc =~ /\A ${Elatin10::dot_s} \z/oxms) {
2739             return wantarray ? ($getc,@_) : $getc;
2740             }
2741 0 0       0 }
2742             }
2743             return wantarray ? ($getc,@_) : $getc;
2744             }
2745              
2746             #
2747             # Latin-10 length by character
2748             #
2749 0 0   0 1 0 sub Latin10::length(;$) {
2750              
2751 0         0 local $_ = shift if @_;
2752 0         0  
2753             local @_ = /\G ($q_char) /oxmsg;
2754             return scalar @_;
2755             }
2756              
2757             #
2758             # Latin-10 substr by character
2759             #
2760             BEGIN {
2761              
2762             # P.232 The lvalue Attribute
2763             # in Chapter 6: Subroutines
2764             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2765              
2766             # P.336 The lvalue Attribute
2767             # in Chapter 7: Subroutines
2768             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2769              
2770             # P.144 8.4 Lvalue subroutines
2771             # in Chapter 8: perlsub: Perl subroutines
2772 206 50 0 206 1 168256 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2773              
2774             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2775             # vv----------------------*******
2776             sub Latin10::substr($$;$$) %s {
2777              
2778             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2779              
2780             # If the substring is beyond either end of the string, substr() returns the undefined
2781             # value and produces a warning. When used as an lvalue, specifying a substring that
2782             # is entirely outside the string raises an exception.
2783             # http://perldoc.perl.org/functions/substr.html
2784              
2785             # A return with no argument returns the scalar value undef in scalar context,
2786             # an empty list () in list context, and (naturally) nothing at all in void
2787             # context.
2788              
2789             my $offset = $_[1];
2790             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2791             return;
2792             }
2793              
2794             # substr($string,$offset,$length,$replacement)
2795             if (@_ == 4) {
2796             my(undef,undef,$length,$replacement) = @_;
2797             my $substr = join '', splice(@char, $offset, $length, $replacement);
2798             $_[0] = join '', @char;
2799              
2800             # return $substr; this doesn't work, don't say "return"
2801             $substr;
2802             }
2803              
2804             # substr($string,$offset,$length)
2805             elsif (@_ == 3) {
2806             my(undef,undef,$length) = @_;
2807             my $octet_offset = 0;
2808             my $octet_length = 0;
2809             if ($offset == 0) {
2810             $octet_offset = 0;
2811             }
2812             elsif ($offset > 0) {
2813             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2814             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2815             }
2816             else {
2817             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2818             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2819             }
2820             if ($length == 0) {
2821             $octet_length = 0;
2822             }
2823             elsif ($length > 0) {
2824             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2825             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2826             }
2827             else {
2828             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2829             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2830             }
2831             CORE::substr($_[0], $octet_offset, $octet_length);
2832             }
2833              
2834             # substr($string,$offset)
2835             else {
2836             my $octet_offset = 0;
2837             if ($offset == 0) {
2838             $octet_offset = 0;
2839             }
2840             elsif ($offset > 0) {
2841             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2842             }
2843             else {
2844             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2845             }
2846             CORE::substr($_[0], $octet_offset);
2847             }
2848             }
2849             END
2850             }
2851              
2852             #
2853             # Latin-10 index by character
2854             #
2855 0     0 1 0 sub Latin10::index($$;$) {
2856 0 0       0  
2857 0         0 my $index;
2858             if (@_ == 3) {
2859             $index = Elatin10::index($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2860 0         0 }
2861             else {
2862             $index = Elatin10::index($_[0], $_[1]);
2863 0 0       0 }
2864 0         0  
2865             if ($index == -1) {
2866             return -1;
2867 0         0 }
2868             else {
2869             return Latin10::length(CORE::substr $_[0], 0, $index);
2870             }
2871             }
2872              
2873             #
2874             # Latin-10 rindex by character
2875             #
2876 0     0 1 0 sub Latin10::rindex($$;$) {
2877 0 0       0  
2878 0         0 my $rindex;
2879             if (@_ == 3) {
2880             $rindex = Elatin10::rindex($_[0], $_[1], CORE::length(Latin10::substr($_[0], 0, $_[2])));
2881 0         0 }
2882             else {
2883             $rindex = Elatin10::rindex($_[0], $_[1]);
2884 0 0       0 }
2885 0         0  
2886             if ($rindex == -1) {
2887             return -1;
2888 0         0 }
2889             else {
2890             return Latin10::length(CORE::substr $_[0], 0, $rindex);
2891             }
2892             }
2893              
2894 206     206   1800 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  206         434  
  206         18220  
2895             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2896             use vars qw($slash); $slash = 'm//';
2897              
2898             # ord() to ord() or Latin10::ord()
2899             my $function_ord = 'ord';
2900              
2901             # ord to ord or Latin10::ord_
2902             my $function_ord_ = 'ord';
2903              
2904             # reverse to reverse or Latin10::reverse
2905             my $function_reverse = 'reverse';
2906              
2907             # getc to getc or Latin10::getc
2908             my $function_getc = 'getc';
2909              
2910             # P.1023 Appendix W.9 Multibyte Anchoring
2911             # of ISBN 1-56592-224-7 CJKV Information Processing
2912              
2913 206     206   1457 my $anchor = '';
  206     0   425  
  206         8472001  
2914              
2915             use vars qw($nest);
2916              
2917             # regexp of nested parens in qqXX
2918              
2919             # P.340 Matching Nested Constructs with Embedded Code
2920             # in Chapter 7: Perl
2921             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2922              
2923             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2924             [^\\()] |
2925             \( (?{$nest++}) |
2926             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2927             \\ [^c] |
2928             \\c[\x40-\x5F] |
2929             [\x00-\xFF]
2930             }xms;
2931              
2932             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2933             [^\\{}] |
2934             \{ (?{$nest++}) |
2935             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2936             \\ [^c] |
2937             \\c[\x40-\x5F] |
2938             [\x00-\xFF]
2939             }xms;
2940              
2941             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2942             [^\\\[\]] |
2943             \[ (?{$nest++}) |
2944             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2945             \\ [^c] |
2946             \\c[\x40-\x5F] |
2947             [\x00-\xFF]
2948             }xms;
2949              
2950             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2951             [^\\<>] |
2952             \< (?{$nest++}) |
2953             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2954             \\ [^c] |
2955             \\c[\x40-\x5F] |
2956             [\x00-\xFF]
2957             }xms;
2958              
2959             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2960             (?: ::)? (?:
2961             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2962             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2963             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2964             ))
2965             }xms;
2966              
2967             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2968             (?: ::)? (?:
2969             (?>[0-9]+) |
2970             [^a-zA-Z_0-9\[\]] |
2971             ^[A-Z] |
2972             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2973             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2974             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2975             ))
2976             }xms;
2977              
2978             my $qq_substr = qr{(?> Char::substr | Latin10::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2979             }xms;
2980              
2981             # regexp of nested parens in qXX
2982             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2983             [^()] |
2984             \( (?{$nest++}) |
2985             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2986             [\x00-\xFF]
2987             }xms;
2988              
2989             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2990             [^\{\}] |
2991             \{ (?{$nest++}) |
2992             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2993             [\x00-\xFF]
2994             }xms;
2995              
2996             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2997             [^\[\]] |
2998             \[ (?{$nest++}) |
2999             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3000             [\x00-\xFF]
3001             }xms;
3002              
3003             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3004             [^<>] |
3005             \< (?{$nest++}) |
3006             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3007             [\x00-\xFF]
3008             }xms;
3009              
3010             my $matched = '';
3011             my $s_matched = '';
3012              
3013             my $tr_variable = ''; # variable of tr///
3014             my $sub_variable = ''; # variable of s///
3015             my $bind_operator = ''; # =~ or !~
3016              
3017             my @heredoc = (); # here document
3018             my @heredoc_delimiter = ();
3019             my $here_script = ''; # here script
3020              
3021             #
3022             # escape Latin-10 script
3023 0 50   206 0 0 #
3024             sub Latin10::escape(;$) {
3025             local($_) = $_[0] if @_;
3026              
3027             # P.359 The Study Function
3028             # in Chapter 7: Perl
3029 206         993 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3030              
3031             study $_; # Yes, I studied study yesterday.
3032              
3033             # while all script
3034              
3035             # 6.14. Matching from Where the Last Pattern Left Off
3036             # in Chapter 6. Pattern Matching
3037             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3038             # (and so on)
3039              
3040             # one member of Tag-team
3041             #
3042             # P.128 Start of match (or end of previous match): \G
3043             # P.130 Advanced Use of \G with Perl
3044             # in Chapter 3: Overview of Regular Expression Features and Flavors
3045             # P.255 Use leading anchors
3046             # P.256 Expose ^ and \G at the front expressions
3047             # in Chapter 6: Crafting an Efficient Expression
3048             # P.315 "Tag-team" matching with /gc
3049             # in Chapter 7: Perl
3050 206         410 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3051 206         365  
3052 206         730 my $e_script = '';
3053             while (not /\G \z/oxgc) { # member
3054             $e_script .= Latin10::escape_token();
3055 75220         137127 }
3056              
3057             return $e_script;
3058             }
3059              
3060             #
3061             # escape Latin-10 token of script
3062             #
3063             sub Latin10::escape_token {
3064              
3065 206     75220 0 2728 # \n output here document
3066              
3067             my $ignore_modules = join('|', qw(
3068             utf8
3069             bytes
3070             charnames
3071             I18N::Japanese
3072             I18N::Collate
3073             I18N::JExt
3074             File::DosGlob
3075             Wild
3076             Wildcard
3077             Japanese
3078             ));
3079              
3080             # another member of Tag-team
3081             #
3082             # P.315 "Tag-team" matching with /gc
3083             # in Chapter 7: Perl
3084 75220 100 100     98995 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3085 75220         3064509  
3086 12548 100       15525 if (/\G ( \n ) /oxgc) { # another member (and so on)
3087 12548         20853 my $heredoc = '';
3088             if (scalar(@heredoc_delimiter) >= 1) {
3089 174         218 $slash = 'm//';
3090 174         321  
3091             $heredoc = join '', @heredoc;
3092             @heredoc = ();
3093 174         285  
3094 174         322 # skip here document
3095             for my $heredoc_delimiter (@heredoc_delimiter) {
3096 174         1176 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3097             }
3098 174         563 @heredoc_delimiter = ();
3099              
3100 174         248 $here_script = '';
3101             }
3102             return "\n" . $heredoc;
3103             }
3104 12548         47095  
3105             # ignore space, comment
3106             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3107              
3108             # if (, elsif (, unless (, while (, until (, given (, and when (
3109              
3110             # given, when
3111              
3112             # P.225 The given Statement
3113             # in Chapter 15: Smart Matching and given-when
3114             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3115              
3116             # P.133 The given Statement
3117             # in Chapter 4: Statements and Declarations
3118             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3119 18057         54986  
3120 1401         2083 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3121             $slash = 'm//';
3122             return $1;
3123             }
3124              
3125             # scalar variable ($scalar = ...) =~ tr///;
3126             # scalar variable ($scalar = ...) =~ s///;
3127              
3128             # state
3129              
3130             # P.68 Persistent, Private Variables
3131             # in Chapter 4: Subroutines
3132             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3133              
3134             # P.160 Persistent Lexically Scoped Variables: state
3135             # in Chapter 4: Statements and Declarations
3136             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3137              
3138             # (and so on)
3139 1401         4483  
3140             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3141 86 50       237 my $e_string = e_string($1);
    50          
3142 86         2217  
3143 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3144 0         0 $tr_variable = $e_string . e_string($1);
3145 0         0 $bind_operator = $2;
3146             $slash = 'm//';
3147             return '';
3148 0         0 }
3149 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3150 0         0 $sub_variable = $e_string . e_string($1);
3151 0         0 $bind_operator = $2;
3152             $slash = 'm//';
3153             return '';
3154 0         0 }
3155 86         154 else {
3156             $slash = 'div';
3157             return $e_string;
3158             }
3159             }
3160              
3161 86         262 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
3162 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3163             $slash = 'div';
3164             return q{Elatin10::PREMATCH()};
3165             }
3166              
3167 4         10 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
3168 28         56 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3169             $slash = 'div';
3170             return q{Elatin10::MATCH()};
3171             }
3172              
3173 28         82 # $', ${'} --> $', ${'}
3174 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3175             $slash = 'div';
3176             return $1;
3177             }
3178              
3179 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
3180 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3181             $slash = 'div';
3182             return q{Elatin10::POSTMATCH()};
3183             }
3184              
3185             # scalar variable $scalar =~ tr///;
3186             # scalar variable $scalar =~ s///;
3187             # substr() =~ tr///;
3188 3         8 # substr() =~ s///;
3189             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3190 1673 100       3620 my $scalar = e_string($1);
    100          
3191 1673         6475  
3192 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3193 1         16 $tr_variable = $scalar;
3194 1         3 $bind_operator = $1;
3195             $slash = 'm//';
3196             return '';
3197 1         5 }
3198 61         114 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3199 61         200 $sub_variable = $scalar;
3200 61         108 $bind_operator = $1;
3201             $slash = 'm//';
3202             return '';
3203 61         170 }
3204 1611         2558 else {
3205             $slash = 'div';
3206             return $scalar;
3207             }
3208             }
3209              
3210 1611         4305 # end of statement
3211             elsif (/\G ( [,;] ) /oxgc) {
3212             $slash = 'm//';
3213 5021         8463  
3214             # clear tr/// variable
3215             $tr_variable = '';
3216 5021         5900  
3217             # clear s/// variable
3218 5021         5442 $sub_variable = '';
3219              
3220 5021         5784 $bind_operator = '';
3221              
3222             return $1;
3223             }
3224              
3225 5021         16563 # bareword
3226             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3227             return $1;
3228             }
3229              
3230 0         0 # $0 --> $0
3231 2         4 elsif (/\G ( \$ 0 ) /oxmsgc) {
3232             $slash = 'div';
3233             return $1;
3234 2         8 }
3235 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3236             $slash = 'div';
3237             return $1;
3238             }
3239              
3240 0         0 # $$ --> $$
3241 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3242             $slash = 'div';
3243             return $1;
3244             }
3245              
3246             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3247 1         3 # $1, $2, $3 --> $1, $2, $3 otherwise
3248 4         7 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3249             $slash = 'div';
3250             return e_capture($1);
3251 4         6 }
3252 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3253             $slash = 'div';
3254             return e_capture($1);
3255             }
3256              
3257 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3258 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3259             $slash = 'div';
3260             return e_capture($1.'->'.$2);
3261             }
3262              
3263 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3264 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3265             $slash = 'div';
3266             return e_capture($1.'->'.$2);
3267             }
3268              
3269 0         0 # $$foo
3270 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3271             $slash = 'div';
3272             return e_capture($1);
3273             }
3274              
3275 0         0 # ${ foo }
3276 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3277             $slash = 'div';
3278             return '${' . $1 . '}';
3279             }
3280              
3281 0         0 # ${ ... }
3282 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3283             $slash = 'div';
3284             return e_capture($1);
3285             }
3286              
3287             # variable or function
3288 0         0 # $ @ % & * $ #
3289 42         75 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) {
3290             $slash = 'div';
3291             return $1;
3292             }
3293             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3294 42         119 # $ @ # \ ' " / ? ( ) [ ] < >
3295 62         133 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3296             $slash = 'div';
3297             return $1;
3298             }
3299              
3300 62         259 # while ()
3301             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3302             return $1;
3303             }
3304              
3305             # while () --- glob
3306              
3307             # avoid "Error: Runtime exception" of perl version 5.005_03
3308 0         0  
3309             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3310             return 'while ($_ = Elatin10::glob("' . $1 . '"))';
3311             }
3312              
3313 0         0 # while (glob)
3314             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3315             return 'while ($_ = Elatin10::glob_)';
3316             }
3317              
3318 0         0 # while (glob(WILDCARD))
3319             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3320             return 'while ($_ = Elatin10::glob';
3321             }
3322 0         0  
  248         572  
3323             # doit if, doit unless, doit while, doit until, doit for, doit when
3324             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3325 248         901  
  19         34  
3326 19         72 # subroutines of package Elatin10
  0         0  
3327 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         17  
3328 13         38 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3329 0         0 elsif (/\G \b Latin10::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         195  
3330 114         316 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3331 2         6 elsif (/\G \b Latin10::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin10::escape'; }
  0         0  
3332 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3333 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chop'; }
  0         0  
3334 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3335 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3336 0         0 elsif (/\G \b Latin10::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::index'; }
  2         4  
3337 2         7 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::index'; }
  0         0  
3338 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3339 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3340 0         0 elsif (/\G \b Latin10::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin10::rindex'; }
  1         3  
3341 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::rindex'; }
  0         0  
3342 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lc'; }
  1         2  
3343 1         4 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst'; }
  0         0  
3344 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::uc'; }
  6         8  
3345             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst'; }
3346             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::fc'; }
3347 6         17  
  0         0  
3348 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3349 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3350 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3351 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3352 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3353 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3354             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3355 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  
3356 0         0  
  0         0  
3357 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3358 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3359 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3360 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3361 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3362             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3363             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3364 0         0  
  0         0  
3365 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3366 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3367 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3368             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3369 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         5  
3370 2         6  
  2         5  
3371 2         8 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         72  
3372 36         104 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         6  
3373 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::chr'; }
  8         41  
3374 8         25 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3375 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3376 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin10::glob'; }
  0         0  
3377 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lc_'; }
  0         0  
3378 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::lcfirst_'; }
  0         0  
3379 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::uc_'; }
  0         0  
3380 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::ucfirst_'; }
  0         0  
3381             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::fc_'; }
3382 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3383 0         0  
  0         0  
3384 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3385 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3386 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::chr_'; }
  0         0  
3387 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3388 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3389 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin10::glob_'; }
  8         20  
3390             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3391             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3392 8         28 # split
3393             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3394 87         182 $slash = 'm//';
3395 87         127  
3396 87         287 my $e = '';
3397             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3398             $e .= $1;
3399             }
3400 85 100       305  
  87 100       5580  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3401             # end of split
3402             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin10::split' . $e; }
3403 2         8  
3404             # split scalar value
3405             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin10::split' . $e . e_string($1); }
3406 1         6  
3407 0         0 # split literal space
3408 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {qq$1 $2}; }
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*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3413 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq{$1qq$2 $3}; }
3414 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin10::split' . $e . qq {q$1 $2}; }
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*)) (\<) [ ] (\>) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3419 10         48 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin10::split' . $e . qq {$1q$2 $3}; }
3420             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin10::split' . $e . qq {' '}; }
3421             elsif (/\G " [ ] " /oxgc) { return 'Elatin10::split' . $e . qq {" "}; }
3422              
3423 0 0       0 # split qq//
  0         0  
3424             elsif (/\G \b (qq) \b /oxgc) {
3425 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3426 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3427 0         0 while (not /\G \z/oxgc) {
3428 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3429 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3430 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3431 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3432 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3433             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3434 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3435             }
3436             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3437             }
3438             }
3439              
3440 0 50       0 # split qr//
  12         400  
3441             elsif (/\G \b (qr) \b /oxgc) {
3442 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3443 12 50       63 else {
  12 50       3306  
    50          
    50          
    50          
    50          
    50          
    50          
3444 0         0 while (not /\G \z/oxgc) {
3445 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3446 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3447 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3448 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3449 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3450 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3451             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3452 12         78 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3453             }
3454             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3455             }
3456             }
3457              
3458 0 0       0 # split q//
  0         0  
3459             elsif (/\G \b (q) \b /oxgc) {
3460 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3461 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3462 0         0 while (not /\G \z/oxgc) {
3463 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3464 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3465 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3466 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3467 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3468             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3469 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3470             }
3471             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3472             }
3473             }
3474              
3475 0 50       0 # split m//
  18         455  
3476             elsif (/\G \b (m) \b /oxgc) {
3477 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3478 18 50       78 else {
  18 50       3728  
    50          
    50          
    50          
    50          
    50          
    50          
3479 0         0 while (not /\G \z/oxgc) {
3480 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3481 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3482 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3483 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3484 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3485 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3486             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3487 18         107 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3488             }
3489             die __FILE__, ": Search pattern not terminated\n";
3490             }
3491             }
3492              
3493 0         0 # split ''
3494 0         0 elsif (/\G (\') /oxgc) {
3495 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3496 0         0 while (not /\G \z/oxgc) {
3497 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3498 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3499             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3500 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3501             }
3502             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3503             }
3504              
3505 0         0 # split ""
3506 0         0 elsif (/\G (\") /oxgc) {
3507 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3508 0         0 while (not /\G \z/oxgc) {
3509 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3510 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3511             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3512 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3513             }
3514             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3515             }
3516              
3517 0         0 # split //
3518 44         115 elsif (/\G (\/) /oxgc) {
3519 44 50       175 my $regexp = '';
  381 50       1508  
    100          
    50          
3520 0         0 while (not /\G \z/oxgc) {
3521 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3522 44         188 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3523             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3524 337         678 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3525             }
3526             die __FILE__, ": Search pattern not terminated\n";
3527             }
3528             }
3529              
3530             # tr/// or y///
3531              
3532             # about [cdsrbB]* (/B modifier)
3533             #
3534             # P.559 appendix C
3535             # of ISBN 4-89052-384-7 Programming perl
3536             # (Japanese title is: Perl puroguramingu)
3537 0         0  
3538             elsif (/\G \b ( tr | y ) \b /oxgc) {
3539             my $ope = $1;
3540 3 50       7  
3541 3         52 # $1 $2 $3 $4 $5 $6
3542 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3543             my @tr = ($tr_variable,$2);
3544             return e_tr(@tr,'',$4,$6);
3545 0         0 }
3546 3         5 else {
3547 3 50       17 my $e = '';
  3 50       230  
    50          
    50          
    50          
    50          
3548             while (not /\G \z/oxgc) {
3549 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3550 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3551 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3552 0         0 while (not /\G \z/oxgc) {
3553 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3554 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3555 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3556 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3557             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3558 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3559             }
3560             die __FILE__, ": Transliteration replacement not terminated\n";
3561 0         0 }
3562 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3563 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3564 0         0 while (not /\G \z/oxgc) {
3565 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3566 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3567 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3568 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3569             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3570 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3571             }
3572             die __FILE__, ": Transliteration replacement not terminated\n";
3573 0         0 }
3574 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3575 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3576 0         0 while (not /\G \z/oxgc) {
3577 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3578 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3579 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3580 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3581             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3582 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3583             }
3584             die __FILE__, ": Transliteration replacement not terminated\n";
3585 0         0 }
3586 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3587 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3588 0         0 while (not /\G \z/oxgc) {
3589 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3590 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3591 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3592 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3593             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3594 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3595             }
3596             die __FILE__, ": Transliteration replacement not terminated\n";
3597             }
3598 0         0 # $1 $2 $3 $4 $5 $6
3599 3         11 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3600             my @tr = ($tr_variable,$2);
3601             return e_tr(@tr,'',$4,$6);
3602 3         7 }
3603             }
3604             die __FILE__, ": Transliteration pattern not terminated\n";
3605             }
3606             }
3607              
3608 0         0 # qq//
3609             elsif (/\G \b (qq) \b /oxgc) {
3610             my $ope = $1;
3611 2180 50       6785  
3612 2180         4592 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3613 0         0 if (/\G (\#) /oxgc) { # qq# #
3614 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3615 0         0 while (not /\G \z/oxgc) {
3616 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3617 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3618             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3619 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3620             }
3621             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3622             }
3623 0         0  
3624 2180         2845 else {
3625 2180 50       4795 my $e = '';
  2180 50       8017  
    100          
    50          
    50          
    0          
3626             while (not /\G \z/oxgc) {
3627             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3628              
3629 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3630 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3631 0         0 my $qq_string = '';
3632 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3633 0         0 while (not /\G \z/oxgc) {
3634 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3635             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3636 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3637 0         0 elsif (/\G (\)) /oxgc) {
3638             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3639 0         0 else { $qq_string .= $1; }
3640             }
3641 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3642             }
3643             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3644             }
3645              
3646 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3647 2150         2859 elsif (/\G (\{) /oxgc) { # qq { }
3648 2150         2823 my $qq_string = '';
3649 2150 100       4130 local $nest = 1;
  84019 50       252266  
    100          
    100          
    50          
3650 722         1328 while (not /\G \z/oxgc) {
3651 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1573  
3652             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3653 1153 100       15304 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         4832  
3654 2150         4191 elsif (/\G (\}) /oxgc) {
3655             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3656 1153         2203 else { $qq_string .= $1; }
3657             }
3658 78841         154040 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3659             }
3660             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3661             }
3662              
3663 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3664 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3665 0         0 my $qq_string = '';
3666 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3667 0         0 while (not /\G \z/oxgc) {
3668 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3669             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3670 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3671 0         0 elsif (/\G (\]) /oxgc) {
3672             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3673 0         0 else { $qq_string .= $1; }
3674             }
3675 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3676             }
3677             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3678             }
3679              
3680 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3681 30         59 elsif (/\G (\<) /oxgc) { # qq < >
3682 30         55 my $qq_string = '';
3683 30 100       136 local $nest = 1;
  1166 50       3987  
    50          
    100          
    50          
3684 22         49 while (not /\G \z/oxgc) {
3685 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3686             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3687 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         63  
3688 30         76 elsif (/\G (\>) /oxgc) {
3689             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3690 0         0 else { $qq_string .= $1; }
3691             }
3692 1114         2138 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3693             }
3694             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3695             }
3696              
3697 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3698 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3699 0         0 my $delimiter = $1;
3700 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3701 0         0 while (not /\G \z/oxgc) {
3702 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3703 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3704             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3705 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3706             }
3707             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3708 0         0 }
3709             }
3710             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3711             }
3712             }
3713              
3714 0         0 # qr//
3715 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3716 0         0 my $ope = $1;
3717             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3718             return e_qr($ope,$1,$3,$2,$4);
3719 0         0 }
3720 0         0 else {
3721 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3722 0         0 while (not /\G \z/oxgc) {
3723 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3724 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3725 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3726 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3727 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3728 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3729             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3730 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3731             }
3732             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3733             }
3734             }
3735              
3736 0         0 # qw//
3737 16 50       47 elsif (/\G \b (qw) \b /oxgc) {
3738 16         84 my $ope = $1;
3739             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3740             return e_qw($ope,$1,$3,$2);
3741 0         0 }
3742 16         35 else {
3743 16 50       62 my $e = '';
  16 50       108  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3744             while (not /\G \z/oxgc) {
3745 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3746 16         62  
3747             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3748 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3749 0         0  
3750             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3751 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3752 0         0  
3753             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3754 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3755 0         0  
3756             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3757 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3758 0         0  
3759             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3760 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3761             }
3762             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3763             }
3764             }
3765              
3766 0         0 # qx//
3767 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3768 0         0 my $ope = $1;
3769             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3770             return e_qq($ope,$1,$3,$2);
3771 0         0 }
3772 0         0 else {
3773 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3774 0         0 while (not /\G \z/oxgc) {
3775 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3776 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3777 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3778 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3779 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3780             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3781 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3782             }
3783             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3784             }
3785             }
3786              
3787 0         0 # q//
3788             elsif (/\G \b (q) \b /oxgc) {
3789             my $ope = $1;
3790              
3791             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3792              
3793             # avoid "Error: Runtime exception" of perl version 5.005_03
3794 410 50       1217 # (and so on)
3795 410         1112  
3796 0         0 if (/\G (\#) /oxgc) { # q# #
3797 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3798 0         0 while (not /\G \z/oxgc) {
3799 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3800 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3801             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3802 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3803             }
3804             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3805             }
3806 0         0  
3807 410         723 else {
3808 410 50       1165 my $e = '';
  410 50       2235  
    100          
    50          
    100          
    50          
3809             while (not /\G \z/oxgc) {
3810             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3811              
3812 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3813 0         0 elsif (/\G (\() /oxgc) { # q ( )
3814 0         0 my $q_string = '';
3815 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3816 0         0 while (not /\G \z/oxgc) {
3817 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3818 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3819             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3820 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3821 0         0 elsif (/\G (\)) /oxgc) {
3822             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3823 0         0 else { $q_string .= $1; }
3824             }
3825 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3826             }
3827             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3828             }
3829              
3830 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3831 404         741 elsif (/\G (\{) /oxgc) { # q { }
3832 404         657 my $q_string = '';
3833 404 50       1146 local $nest = 1;
  6783 50       25696  
    50          
    100          
    100          
    50          
3834 0         0 while (not /\G \z/oxgc) {
3835 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3836 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         367  
3837             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3838 107 100       220 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         974  
3839 404         1266 elsif (/\G (\}) /oxgc) {
3840             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3841 107         207 else { $q_string .= $1; }
3842             }
3843 6165         11867 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3844             }
3845             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3846             }
3847              
3848 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3849 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3850 0         0 my $q_string = '';
3851 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3852 0         0 while (not /\G \z/oxgc) {
3853 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3854 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3855             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3856 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3857 0         0 elsif (/\G (\]) /oxgc) {
3858             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3859 0         0 else { $q_string .= $1; }
3860             }
3861 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3862             }
3863             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3864             }
3865              
3866 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3867 5         11 elsif (/\G (\<) /oxgc) { # q < >
3868 5         8 my $q_string = '';
3869 5 50       16 local $nest = 1;
  88 50       389  
    50          
    50          
    100          
    50          
3870 0         0 while (not /\G \z/oxgc) {
3871 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3872 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3873             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3874 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         14  
3875 5         13 elsif (/\G (\>) /oxgc) {
3876             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3877 0         0 else { $q_string .= $1; }
3878             }
3879 83         160 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3880             }
3881             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3882             }
3883              
3884 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3885 1         3 elsif (/\G (\S) /oxgc) { # q * *
3886 1         3 my $delimiter = $1;
3887 1 50       4 my $q_string = '';
  14 50       62  
    100          
    50          
3888 0         0 while (not /\G \z/oxgc) {
3889 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3890 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3891             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3892 13         29 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3893             }
3894             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3895 0         0 }
3896             }
3897             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3898             }
3899             }
3900              
3901 0         0 # m//
3902 209 50       486 elsif (/\G \b (m) \b /oxgc) {
3903 209         2484 my $ope = $1;
3904             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3905             return e_qr($ope,$1,$3,$2,$4);
3906 0         0 }
3907 209         313 else {
3908 209 50       511 my $e = '';
  209 50       26983  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3909 0         0 while (not /\G \z/oxgc) {
3910 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3911 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3912 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3913 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3914 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3915 10         28 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3916 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3917             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3918 199         621 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3919             }
3920             die __FILE__, ": Search pattern not terminated\n";
3921             }
3922             }
3923              
3924             # s///
3925              
3926             # about [cegimosxpradlunbB]* (/cg modifier)
3927             #
3928             # P.67 Pattern-Matching Operators
3929             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3930 0         0  
3931             elsif (/\G \b (s) \b /oxgc) {
3932             my $ope = $1;
3933 97 100       261  
3934 97         1591 # $1 $2 $3 $4 $5 $6
3935             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3936             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3937 1         5 }
3938 96         177 else {
3939 96 50       349 my $e = '';
  96 50       12018  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3940             while (not /\G \z/oxgc) {
3941 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3942 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3943 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3944             while (not /\G \z/oxgc) {
3945 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3946 0         0 # $1 $2 $3 $4
3947 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956             }
3957             die __FILE__, ": Substitution replacement not terminated\n";
3958 0         0 }
3959 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3960 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3961             while (not /\G \z/oxgc) {
3962 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3963 0         0 # $1 $2 $3 $4
3964 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973             }
3974             die __FILE__, ": Substitution replacement not terminated\n";
3975 0         0 }
3976 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3977 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3978             while (not /\G \z/oxgc) {
3979 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3980 0         0 # $1 $2 $3 $4
3981 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3987 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3988             }
3989             die __FILE__, ": Substitution replacement not terminated\n";
3990 0         0 }
3991 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3992 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3993             while (not /\G \z/oxgc) {
3994 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3995 0         0 # $1 $2 $3 $4
3996 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3997 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3998 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3999 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4004 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4005             }
4006             die __FILE__, ": Substitution replacement not terminated\n";
4007             }
4008 0         0 # $1 $2 $3 $4 $5 $6
4009             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4010             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4011             }
4012 21         57 # $1 $2 $3 $4 $5 $6
4013             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4014             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4015             }
4016 0         0 # $1 $2 $3 $4 $5 $6
4017             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4018             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4019             }
4020 0         0 # $1 $2 $3 $4 $5 $6
4021             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4022             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4023 75         331 }
4024             }
4025             die __FILE__, ": Substitution pattern not terminated\n";
4026             }
4027             }
4028 0         0  
4029 0         0 # require ignore module
4030 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4031             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4032             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4033 0         0  
4034 37         350 # use strict; --> use strict; no strict qw(refs);
4035 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4036             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4037             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4038              
4039 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4040 2         35 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4041             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4042             return "use $1; no strict qw(refs);";
4043 0         0 }
4044             else {
4045             return "use $1;";
4046             }
4047 2 0 0     13 }
      0        
4048 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4049             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4050             return "use $1; no strict qw(refs);";
4051 0         0 }
4052             else {
4053             return "use $1;";
4054             }
4055             }
4056 0         0  
4057 2         15 # ignore use module
4058 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4059             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4060             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4061 0         0  
4062 0         0 # ignore no module
4063 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4064             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4065             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4066 0         0  
4067             # use else
4068             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4069 0         0  
4070             # use else
4071             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4072              
4073 2         9 # ''
4074 848         1835 elsif (/\G (?
4075 848 100       2128 my $q_string = '';
  8267 100       24695  
    100          
    50          
4076 4         10 while (not /\G \z/oxgc) {
4077 48         91 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4078 848         1915 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4079             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4080 7367         14064 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4081             }
4082             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4083             }
4084              
4085 0         0 # ""
4086 1834         3659 elsif (/\G (\") /oxgc) {
4087 1834 100       4342 my $qq_string = '';
  35544 100       101430  
    100          
    50          
4088 67         286 while (not /\G \z/oxgc) {
4089 12         24 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4090 1834         3857 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4091             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4092 33631         72932 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4093             }
4094             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4095             }
4096              
4097 0         0 # ``
4098 1         3 elsif (/\G (\`) /oxgc) {
4099 1 50       5 my $qx_string = '';
  19 50       72  
    100          
    50          
4100 0         0 while (not /\G \z/oxgc) {
4101 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4102 1         4 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4103             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4104 18         30 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4105             }
4106             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4107             }
4108              
4109 0         0 # // --- not divide operator (num / num), not defined-or
4110 453         1032 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4111 453 50       1233 my $regexp = '';
  4496 50       23219  
    100          
    50          
4112 0         0 while (not /\G \z/oxgc) {
4113 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4114 453         1493 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4115             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4116 4043         8110 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4117             }
4118             die __FILE__, ": Search pattern not terminated\n";
4119             }
4120              
4121 0         0 # ?? --- not conditional operator (condition ? then : else)
4122 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4123 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4124 0         0 while (not /\G \z/oxgc) {
4125 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4126 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4127             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4128 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4129             }
4130             die __FILE__, ": Search pattern not terminated\n";
4131             }
4132 0         0  
  0         0  
4133             # <<>> (a safer ARGV)
4134             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4135 0         0  
  0         0  
4136             # << (bit shift) --- not here document
4137             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4138              
4139 0         0 # <<~'HEREDOC'
4140 6         12 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4141 6         13 $slash = 'm//';
4142             my $here_quote = $1;
4143             my $delimiter = $2;
4144 6 50       7  
4145 6         13 # get here document
4146 6         19 if ($here_script eq '') {
4147             $here_script = CORE::substr $_, pos $_;
4148 6 50       31 $here_script =~ s/.*?\n//oxm;
4149 6         62 }
4150 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4151 6         9 my $heredoc = $1;
4152 6         46 my $indent = $2;
4153 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4154             push @heredoc, $heredoc . qq{\n$delimiter\n};
4155             push @heredoc_delimiter, qq{\\s*$delimiter};
4156 6         12 }
4157             else {
4158 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4159             }
4160             return qq{<<'$delimiter'};
4161             }
4162              
4163             # <<~\HEREDOC
4164              
4165             # P.66 2.6.6. "Here" Documents
4166             # in Chapter 2: Bits and Pieces
4167             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4168              
4169             # P.73 "Here" Documents
4170             # in Chapter 2: Bits and Pieces
4171             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4172 6         21  
4173 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4174 3         4 $slash = 'm//';
4175             my $here_quote = $1;
4176             my $delimiter = $2;
4177 3 50       8  
4178 3         6 # get here document
4179 3         31 if ($here_script eq '') {
4180             $here_script = CORE::substr $_, pos $_;
4181 3 50       19 $here_script =~ s/.*?\n//oxm;
4182 3         45 }
4183 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4184 3         9 my $heredoc = $1;
4185 3         53 my $indent = $2;
4186 3         13 $heredoc =~ s{^$indent}{}msg; # no /ox
4187             push @heredoc, $heredoc . qq{\n$delimiter\n};
4188             push @heredoc_delimiter, qq{\\s*$delimiter};
4189 3         8 }
4190             else {
4191 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4192             }
4193             return qq{<<\\$delimiter};
4194             }
4195              
4196 3         15 # <<~"HEREDOC"
4197 6         11 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4198 6         11 $slash = 'm//';
4199             my $here_quote = $1;
4200             my $delimiter = $2;
4201 6 50       13  
4202 6         11 # get here document
4203 6         31 if ($here_script eq '') {
4204             $here_script = CORE::substr $_, pos $_;
4205 6 50       29 $here_script =~ s/.*?\n//oxm;
4206 6         66 }
4207 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4208 6         9 my $heredoc = $1;
4209 6         88 my $indent = $2;
4210 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4211             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4212             push @heredoc_delimiter, qq{\\s*$delimiter};
4213 6         15 }
4214             else {
4215 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4216             }
4217             return qq{<<"$delimiter"};
4218             }
4219              
4220 6         38 # <<~HEREDOC
4221 3         8 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4222 3         7 $slash = 'm//';
4223             my $here_quote = $1;
4224             my $delimiter = $2;
4225 3 50       8  
4226 3         16 # get here document
4227 3         60 if ($here_script eq '') {
4228             $here_script = CORE::substr $_, pos $_;
4229 3 50       19 $here_script =~ s/.*?\n//oxm;
4230 3         48 }
4231 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4232 3         5 my $heredoc = $1;
4233 3         49 my $indent = $2;
4234 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
4235             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4236             push @heredoc_delimiter, qq{\\s*$delimiter};
4237 3         10 }
4238             else {
4239 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4240             }
4241             return qq{<<$delimiter};
4242             }
4243              
4244 3         15 # <<~`HEREDOC`
4245 6         16 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4246 6         13 $slash = 'm//';
4247             my $here_quote = $1;
4248             my $delimiter = $2;
4249 6 50       22  
4250 6         17 # get here document
4251 6         21 if ($here_script eq '') {
4252             $here_script = CORE::substr $_, pos $_;
4253 6 50       38 $here_script =~ s/.*?\n//oxm;
4254 6         62 }
4255 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4256 6         9 my $heredoc = $1;
4257 6         52 my $indent = $2;
4258 6         22 $heredoc =~ s{^$indent}{}msg; # no /ox
4259             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4260             push @heredoc_delimiter, qq{\\s*$delimiter};
4261 6         17 }
4262             else {
4263 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4264             }
4265             return qq{<<`$delimiter`};
4266             }
4267              
4268 6         25 # <<'HEREDOC'
4269 72         138 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4270 72         139 $slash = 'm//';
4271             my $here_quote = $1;
4272             my $delimiter = $2;
4273 72 50       112  
4274 72         135 # get here document
4275 72         368 if ($here_script eq '') {
4276             $here_script = CORE::substr $_, pos $_;
4277 72 50       424 $here_script =~ s/.*?\n//oxm;
4278 72         543 }
4279 72         243 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4280             push @heredoc, $1 . qq{\n$delimiter\n};
4281             push @heredoc_delimiter, $delimiter;
4282 72         110 }
4283             else {
4284 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4285             }
4286             return $here_quote;
4287             }
4288              
4289             # <<\HEREDOC
4290              
4291             # P.66 2.6.6. "Here" Documents
4292             # in Chapter 2: Bits and Pieces
4293             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4294              
4295             # P.73 "Here" Documents
4296             # in Chapter 2: Bits and Pieces
4297             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4298 72         281  
4299 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4300 0         0 $slash = 'm//';
4301             my $here_quote = $1;
4302             my $delimiter = $2;
4303 0 0       0  
4304 0         0 # get here document
4305 0         0 if ($here_script eq '') {
4306             $here_script = CORE::substr $_, pos $_;
4307 0 0       0 $here_script =~ s/.*?\n//oxm;
4308 0         0 }
4309 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4310             push @heredoc, $1 . qq{\n$delimiter\n};
4311             push @heredoc_delimiter, $delimiter;
4312 0         0 }
4313             else {
4314 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4315             }
4316             return $here_quote;
4317             }
4318              
4319 0         0 # <<"HEREDOC"
4320 36         86 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4321 36         80 $slash = 'm//';
4322             my $here_quote = $1;
4323             my $delimiter = $2;
4324 36 50       476  
4325 36         107 # get here document
4326 36         238 if ($here_script eq '') {
4327             $here_script = CORE::substr $_, pos $_;
4328 36 50       222 $here_script =~ s/.*?\n//oxm;
4329 36         793 }
4330 36         114 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4331             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4332             push @heredoc_delimiter, $delimiter;
4333 36         152 }
4334             else {
4335 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4336             }
4337             return $here_quote;
4338             }
4339              
4340 36         170 # <
4341 42         104 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4342 42         99 $slash = 'm//';
4343             my $here_quote = $1;
4344             my $delimiter = $2;
4345 42 50       87  
4346 42         113 # get here document
4347 42         307 if ($here_script eq '') {
4348             $here_script = CORE::substr $_, pos $_;
4349 42 50       362 $here_script =~ s/.*?\n//oxm;
4350 42         582 }
4351 42         182 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4352             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4353             push @heredoc_delimiter, $delimiter;
4354 42         111 }
4355             else {
4356 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4357             }
4358             return $here_quote;
4359             }
4360              
4361 42         176 # <<`HEREDOC`
4362 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4363 0         0 $slash = 'm//';
4364             my $here_quote = $1;
4365             my $delimiter = $2;
4366 0 0       0  
4367 0         0 # get here document
4368 0         0 if ($here_script eq '') {
4369             $here_script = CORE::substr $_, pos $_;
4370 0 0       0 $here_script =~ s/.*?\n//oxm;
4371 0         0 }
4372 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4373             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4374             push @heredoc_delimiter, $delimiter;
4375 0         0 }
4376             else {
4377 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4378             }
4379             return $here_quote;
4380             }
4381              
4382 0         0 # <<= <=> <= < operator
4383             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4384             return $1;
4385             }
4386              
4387 12         62 #
4388             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4389             return $1;
4390             }
4391              
4392             # --- glob
4393              
4394             # avoid "Error: Runtime exception" of perl version 5.005_03
4395 0         0  
4396             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4397             return 'Elatin10::glob("' . $1 . '")';
4398             }
4399 0         0  
4400             # __DATA__
4401             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4402 0         0  
4403             # __END__
4404             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4405              
4406             # \cD Control-D
4407              
4408             # P.68 2.6.8. Other Literal Tokens
4409             # in Chapter 2: Bits and Pieces
4410             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4411              
4412             # P.76 Other Literal Tokens
4413             # in Chapter 2: Bits and Pieces
4414 204         1496 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4415              
4416             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4417 0         0  
4418             # \cZ Control-Z
4419             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4420              
4421             # any operator before div
4422             elsif (/\G (
4423             -- | \+\+ |
4424 0         0 [\)\}\]]
  5083         10036  
4425              
4426             ) /oxgc) { $slash = 'div'; return $1; }
4427              
4428             # yada-yada or triple-dot operator
4429             elsif (/\G (
4430 5083         22017 \.\.\.
  7         13  
4431              
4432             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4433              
4434             # any operator before m//
4435              
4436             # //, //= (defined-or)
4437              
4438             # P.164 Logical Operators
4439             # in Chapter 10: More Control Structures
4440             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4441              
4442             # P.119 C-Style Logical (Short-Circuit) Operators
4443             # in Chapter 3: Unary and Binary Operators
4444             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4445              
4446             # (and so on)
4447              
4448             # ~~
4449              
4450             # P.221 The Smart Match Operator
4451             # in Chapter 15: Smart Matching and given-when
4452             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4453              
4454             # P.112 Smartmatch Operator
4455             # in Chapter 3: Unary and Binary Operators
4456             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4457              
4458             # (and so on)
4459              
4460             elsif (/\G ((?>
4461              
4462             !~~ | !~ | != | ! |
4463             %= | % |
4464             &&= | && | &= | &\.= | &\. | & |
4465             -= | -> | - |
4466             :(?>\s*)= |
4467             : |
4468             <<>> |
4469             <<= | <=> | <= | < |
4470             == | => | =~ | = |
4471             >>= | >> | >= | > |
4472             \*\*= | \*\* | \*= | \* |
4473             \+= | \+ |
4474             \.\. | \.= | \. |
4475             \/\/= | \/\/ |
4476             \/= | \/ |
4477             \? |
4478             \\ |
4479             \^= | \^\.= | \^\. | \^ |
4480             \b x= |
4481             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4482             ~~ | ~\. | ~ |
4483             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4484             \b(?: print )\b |
4485              
4486 7         24 [,;\(\{\[]
  8871         16851  
4487              
4488             )) /oxgc) { $slash = 'm//'; return $1; }
4489 8871         37374  
  15289         28556  
4490             # other any character
4491             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4492              
4493 15289         86503 # system error
4494             else {
4495             die __FILE__, ": Oops, this shouldn't happen!\n";
4496             }
4497             }
4498              
4499 0     1788 0 0 # escape Latin-10 string
4500 1788         4140 sub e_string {
4501             my($string) = @_;
4502 1788         2495 my $e_string = '';
4503              
4504             local $slash = 'm//';
4505              
4506             # P.1024 Appendix W.10 Multibyte Processing
4507             # of ISBN 1-56592-224-7 CJKV Information Processing
4508 1788         2604 # (and so on)
4509              
4510             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4511 1788 100 66     16466  
4512 1788 50       7518 # without { ... }
4513 1769         4133 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4514             if ($string !~ /<
4515             return $string;
4516             }
4517             }
4518 1769         4512  
4519 19 50       64 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
4520             while ($string !~ /\G \z/oxgc) {
4521             if (0) {
4522             }
4523 223         3580  
4524 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin10::PREMATCH()]}
4525 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4526             $e_string .= q{Elatin10::PREMATCH()};
4527             $slash = 'div';
4528             }
4529              
4530 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin10::MATCH()]}
4531 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4532             $e_string .= q{Elatin10::MATCH()};
4533             $slash = 'div';
4534             }
4535              
4536 0         0 # $', ${'} --> $', ${'}
4537 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4538             $e_string .= $1;
4539             $slash = 'div';
4540             }
4541              
4542 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin10::POSTMATCH()]}
4543 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4544             $e_string .= q{Elatin10::POSTMATCH()};
4545             $slash = 'div';
4546             }
4547              
4548 0         0 # bareword
4549 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4550             $e_string .= $1;
4551             $slash = 'div';
4552             }
4553              
4554 0         0 # $0 --> $0
4555 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4556             $e_string .= $1;
4557             $slash = 'div';
4558 0         0 }
4559 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4560             $e_string .= $1;
4561             $slash = 'div';
4562             }
4563              
4564 0         0 # $$ --> $$
4565 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4566             $e_string .= $1;
4567             $slash = 'div';
4568             }
4569              
4570             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4571 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4572 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4573             $e_string .= e_capture($1);
4574             $slash = 'div';
4575 0         0 }
4576 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4577             $e_string .= e_capture($1);
4578             $slash = 'div';
4579             }
4580              
4581 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4582 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4583             $e_string .= e_capture($1.'->'.$2);
4584             $slash = 'div';
4585             }
4586              
4587 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4588 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4589             $e_string .= e_capture($1.'->'.$2);
4590             $slash = 'div';
4591             }
4592              
4593 0         0 # $$foo
4594 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4595             $e_string .= e_capture($1);
4596             $slash = 'div';
4597             }
4598              
4599 0         0 # ${ foo }
4600 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4601             $e_string .= '${' . $1 . '}';
4602             $slash = 'div';
4603             }
4604              
4605 0         0 # ${ ... }
4606 3         14 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4607             $e_string .= e_capture($1);
4608             $slash = 'div';
4609             }
4610              
4611             # variable or function
4612 3         14 # $ @ % & * $ #
4613 7         21 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) {
4614             $e_string .= $1;
4615             $slash = 'div';
4616             }
4617             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4618 7         24 # $ @ # \ ' " / ? ( ) [ ] < >
4619 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4620             $e_string .= $1;
4621             $slash = 'div';
4622             }
4623              
4624 0         0 # qq//
4625 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4626 0         0 my $ope = $1;
4627             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4628             $e_string .= e_qq($ope,$1,$3,$2);
4629 0         0 }
4630 0         0 else {
4631 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4632 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4633 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4634 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4635 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4636 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4637             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4638 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4639             }
4640             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4641             }
4642             }
4643              
4644 0         0 # qx//
4645 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4646 0         0 my $ope = $1;
4647             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4648             $e_string .= e_qq($ope,$1,$3,$2);
4649 0         0 }
4650 0         0 else {
4651 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4652 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4653 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4654 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4655 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4656 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4657 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4658             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4659 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4660             }
4661             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4662             }
4663             }
4664              
4665 0         0 # q//
4666 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4667 0         0 my $ope = $1;
4668             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4669             $e_string .= e_q($ope,$1,$3,$2);
4670 0         0 }
4671 0         0 else {
4672 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4673 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4674 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4675 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4676 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4677 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4678             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4679 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 * *
4680             }
4681             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4682             }
4683             }
4684 0         0  
4685             # ''
4686             elsif ($string =~ /\G (?
4687 0         0  
4688             # ""
4689             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4690 0         0  
4691             # ``
4692             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4693 0         0  
4694             # other any character
4695             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4696              
4697 213         465 # system error
4698             else {
4699             die __FILE__, ": Oops, this shouldn't happen!\n";
4700             }
4701 0         0 }
4702              
4703             return $e_string;
4704             }
4705              
4706             #
4707             # character class
4708 19     1919 0 72 #
4709             sub character_class {
4710 1919 100       4478 my($char,$modifier) = @_;
4711 1919 100       2981  
4712 52         96 if ($char eq '.') {
4713             if ($modifier =~ /s/) {
4714             return '${Elatin10::dot_s}';
4715 17         35 }
4716             else {
4717             return '${Elatin10::dot}';
4718             }
4719 35         75 }
4720             else {
4721             return Elatin10::classic_character_class($char);
4722             }
4723             }
4724              
4725             #
4726             # escape capture ($1, $2, $3, ...)
4727             #
4728 1867     212 0 3223 sub e_capture {
4729              
4730             return join '', '${', $_[0], '}';
4731             }
4732              
4733             #
4734             # escape transliteration (tr/// or y///)
4735 212     3 0 801 #
4736 3         11 sub e_tr {
4737 3   50     5 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4738             my $e_tr = '';
4739 3         6 $modifier ||= '';
4740              
4741             $slash = 'div';
4742 3         4  
4743             # quote character class 1
4744             $charclass = q_tr($charclass);
4745 3         6  
4746             # quote character class 2
4747             $charclass2 = q_tr($charclass2);
4748 3 50       6  
4749 3 0       10 # /b /B modifier
4750 0         0 if ($modifier =~ tr/bB//d) {
4751             if ($variable eq '') {
4752             $e_tr = qq{tr$charclass$e$charclass2$modifier};
4753 0         0 }
4754             else {
4755             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4756             }
4757 0 100       0 }
4758 3         6 else {
4759             if ($variable eq '') {
4760             $e_tr = qq{Elatin10::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4761 2         15 }
4762             else {
4763             $e_tr = qq{Elatin10::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4764             }
4765             }
4766 1         6  
4767 3         5 # clear tr/// variable
4768             $tr_variable = '';
4769 3         3 $bind_operator = '';
4770              
4771             return $e_tr;
4772             }
4773              
4774             #
4775             # quote for escape transliteration (tr/// or y///)
4776 3     6 0 17 #
4777             sub q_tr {
4778             my($charclass) = @_;
4779 6 50       8  
    0          
    0          
    0          
    0          
    0          
4780 6         13 # quote character class
4781             if ($charclass !~ /'/oxms) {
4782             return e_q('', "'", "'", $charclass); # --> q' '
4783 6         10 }
4784             elsif ($charclass !~ /\//oxms) {
4785             return e_q('q', '/', '/', $charclass); # --> q/ /
4786 0         0 }
4787             elsif ($charclass !~ /\#/oxms) {
4788             return e_q('q', '#', '#', $charclass); # --> q# #
4789 0         0 }
4790             elsif ($charclass !~ /[\<\>]/oxms) {
4791             return e_q('q', '<', '>', $charclass); # --> q< >
4792 0         0 }
4793             elsif ($charclass !~ /[\(\)]/oxms) {
4794             return e_q('q', '(', ')', $charclass); # --> q( )
4795 0         0 }
4796             elsif ($charclass !~ /[\{\}]/oxms) {
4797             return e_q('q', '{', '}', $charclass); # --> q{ }
4798 0         0 }
4799 0 0       0 else {
4800 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4801             if ($charclass !~ /\Q$char\E/xms) {
4802             return e_q('q', $char, $char, $charclass);
4803             }
4804             }
4805 0         0 }
4806              
4807             return e_q('q', '{', '}', $charclass);
4808             }
4809              
4810             #
4811             # escape q string (q//, '')
4812 0     1264 0 0 #
4813             sub e_q {
4814 1264         3093 my($ope,$delimiter,$end_delimiter,$string) = @_;
4815              
4816 1264         1632 $slash = 'div';
4817              
4818             return join '', $ope, $delimiter, $string, $end_delimiter;
4819             }
4820              
4821             #
4822             # escape qq string (qq//, "", qx//, ``)
4823 1264     4096 0 5867 #
4824             sub e_qq {
4825 4096         8750 my($ope,$delimiter,$end_delimiter,$string) = @_;
4826              
4827 4096         5250 $slash = 'div';
4828 4096         4934  
4829             my $left_e = 0;
4830             my $right_e = 0;
4831 4096         16716  
4832             # split regexp
4833             my @char = $string =~ /\G((?>
4834             [^\\\$] |
4835             \\x\{ (?>[0-9A-Fa-f]+) \} |
4836             \\o\{ (?>[0-7]+) \} |
4837             \\N\{ (?>[^0-9\}][^\}]*) \} |
4838             \\ $q_char |
4839             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
4840             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
4841             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
4842             \$ (?>\s* [0-9]+) |
4843             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
4844             \$ \$ (?![\w\{]) |
4845             \$ (?>\s*) \$ (?>\s*) $qq_variable |
4846             $q_char
4847 4096         133607 ))/oxmsg;
4848              
4849             for (my $i=0; $i <= $#char; $i++) {
4850 4096 50 33     28854  
    50 33        
    100          
    100          
    50          
4851 114149         377914 # "\L\u" --> "\u\L"
4852             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
4853             @char[$i,$i+1] = @char[$i+1,$i];
4854             }
4855              
4856 0         0 # "\U\l" --> "\l\U"
4857             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
4858             @char[$i,$i+1] = @char[$i+1,$i];
4859             }
4860              
4861 0         0 # octal escape sequence
4862             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
4863             $char[$i] = Elatin10::octchr($1);
4864             }
4865              
4866 1         4 # hexadecimal escape sequence
4867             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
4868             $char[$i] = Elatin10::hexchr($1);
4869             }
4870              
4871 1         4 # \N{CHARNAME} --> N{CHARNAME}
4872             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4873             $char[$i] = $1;
4874 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
4875              
4876             if (0) {
4877             }
4878              
4879             # \F
4880             #
4881             # P.69 Table 2-6. Translation escapes
4882             # in Chapter 2: Bits and Pieces
4883             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4884             # (and so on)
4885 114149         912527  
4886 0 50       0 # \u \l \U \L \F \Q \E
4887 484         985 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
4888             if ($right_e < $left_e) {
4889             $char[$i] = '\\' . $char[$i];
4890             }
4891             }
4892             elsif ($char[$i] eq '\u') {
4893              
4894             # "STRING @{[ LIST EXPR ]} MORE STRING"
4895              
4896             # P.257 Other Tricks You Can Do with Hard References
4897             # in Chapter 8: References
4898             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4899              
4900             # P.353 Other Tricks You Can Do with Hard References
4901             # in Chapter 8: References
4902             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4903              
4904 0         0 # (and so on)
4905 0         0  
4906             $char[$i] = '@{[Elatin10::ucfirst qq<';
4907             $left_e++;
4908 0         0 }
4909 0         0 elsif ($char[$i] eq '\l') {
4910             $char[$i] = '@{[Elatin10::lcfirst qq<';
4911             $left_e++;
4912 0         0 }
4913 0         0 elsif ($char[$i] eq '\U') {
4914             $char[$i] = '@{[Elatin10::uc qq<';
4915             $left_e++;
4916 0         0 }
4917 0         0 elsif ($char[$i] eq '\L') {
4918             $char[$i] = '@{[Elatin10::lc qq<';
4919             $left_e++;
4920 0         0 }
4921 24         33 elsif ($char[$i] eq '\F') {
4922             $char[$i] = '@{[Elatin10::fc qq<';
4923             $left_e++;
4924 24         40 }
4925 0         0 elsif ($char[$i] eq '\Q') {
4926             $char[$i] = '@{[CORE::quotemeta qq<';
4927             $left_e++;
4928 0 50       0 }
4929 24         35 elsif ($char[$i] eq '\E') {
4930 24         27 if ($right_e < $left_e) {
4931             $char[$i] = '>]}';
4932             $right_e++;
4933 24         37 }
4934             else {
4935             $char[$i] = '';
4936             }
4937 0         0 }
4938 0 0       0 elsif ($char[$i] eq '\Q') {
4939 0         0 while (1) {
4940             if (++$i > $#char) {
4941 0 0       0 last;
4942 0         0 }
4943             if ($char[$i] eq '\E') {
4944             last;
4945             }
4946             }
4947             }
4948             elsif ($char[$i] eq '\E') {
4949             }
4950              
4951             # $0 --> $0
4952             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
4953             }
4954             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
4955             }
4956              
4957             # $$ --> $$
4958             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
4959             }
4960              
4961             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4962 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4963             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
4964             $char[$i] = e_capture($1);
4965 205         371 }
4966             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
4967             $char[$i] = e_capture($1);
4968             }
4969              
4970 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4971             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
4972             $char[$i] = e_capture($1.'->'.$2);
4973             }
4974              
4975 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4976             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
4977             $char[$i] = e_capture($1.'->'.$2);
4978             }
4979              
4980 0         0 # $$foo
4981             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
4982             $char[$i] = e_capture($1);
4983             }
4984              
4985 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
4986             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
4987             $char[$i] = '@{[Elatin10::PREMATCH()]}';
4988             }
4989              
4990 44         145 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
4991             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
4992             $char[$i] = '@{[Elatin10::MATCH()]}';
4993             }
4994              
4995 45         125 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
4996             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
4997             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
4998             }
4999              
5000             # ${ foo } --> ${ foo }
5001             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5002             }
5003              
5004 33         84 # ${ ... }
5005             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5006             $char[$i] = e_capture($1);
5007             }
5008             }
5009 0 50       0  
5010 4096         7702 # return string
5011             if ($left_e > $right_e) {
5012 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5013             }
5014             return join '', $ope, $delimiter, @char, $end_delimiter;
5015             }
5016              
5017             #
5018             # escape qw string (qw//)
5019 4096     16 0 32046 #
5020             sub e_qw {
5021 16         119 my($ope,$delimiter,$end_delimiter,$string) = @_;
5022              
5023             $slash = 'div';
5024 16         39  
  16         232  
5025 483 50       725 # choice again delimiter
    0          
    0          
    0          
    0          
5026 16         91 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5027             if (not $octet{$end_delimiter}) {
5028             return join '', $ope, $delimiter, $string, $end_delimiter;
5029 16         120 }
5030             elsif (not $octet{')'}) {
5031             return join '', $ope, '(', $string, ')';
5032 0         0 }
5033             elsif (not $octet{'}'}) {
5034             return join '', $ope, '{', $string, '}';
5035 0         0 }
5036             elsif (not $octet{']'}) {
5037             return join '', $ope, '[', $string, ']';
5038 0         0 }
5039             elsif (not $octet{'>'}) {
5040             return join '', $ope, '<', $string, '>';
5041 0         0 }
5042 0 0       0 else {
5043 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5044             if (not $octet{$char}) {
5045             return join '', $ope, $char, $string, $char;
5046             }
5047             }
5048             }
5049 0         0  
5050 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5051 0         0 my @string = CORE::split(/\s+/, $string);
5052 0         0 for my $string (@string) {
5053 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5054 0         0 for my $octet (@octet) {
5055             if ($octet =~ /\A (['\\]) \z/oxms) {
5056             $octet = '\\' . $1;
5057 0         0 }
5058             }
5059 0         0 $string = join '', @octet;
  0         0  
5060             }
5061             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5062             }
5063              
5064             #
5065             # escape here document (<<"HEREDOC", <
5066 0     93 0 0 #
5067             sub e_heredoc {
5068 93         328 my($string) = @_;
5069              
5070 93         217 $slash = 'm//';
5071              
5072 93         347 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5073 93         171  
5074             my $left_e = 0;
5075             my $right_e = 0;
5076 93         138  
5077             # split regexp
5078             my @char = $string =~ /\G((?>
5079             [^\\\$] |
5080             \\x\{ (?>[0-9A-Fa-f]+) \} |
5081             \\o\{ (?>[0-7]+) \} |
5082             \\N\{ (?>[^0-9\}][^\}]*) \} |
5083             \\ $q_char |
5084             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5085             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5086             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5087             \$ (?>\s* [0-9]+) |
5088             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5089             \$ \$ (?![\w\{]) |
5090             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5091             $q_char
5092 93         8091 ))/oxmsg;
5093              
5094             for (my $i=0; $i <= $#char; $i++) {
5095 93 50 33     475  
    50 33        
    100          
    100          
    50          
5096 3203         18824 # "\L\u" --> "\u\L"
5097             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5098             @char[$i,$i+1] = @char[$i+1,$i];
5099             }
5100              
5101 0         0 # "\U\l" --> "\l\U"
5102             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5103             @char[$i,$i+1] = @char[$i+1,$i];
5104             }
5105              
5106 0         0 # octal escape sequence
5107             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5108             $char[$i] = Elatin10::octchr($1);
5109             }
5110              
5111 1         4 # hexadecimal escape sequence
5112             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5113             $char[$i] = Elatin10::hexchr($1);
5114             }
5115              
5116 1         4 # \N{CHARNAME} --> N{CHARNAME}
5117             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5118             $char[$i] = $1;
5119 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5120              
5121             if (0) {
5122             }
5123 3203         27729  
5124 0 0       0 # \u \l \U \L \F \Q \E
5125 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5126             if ($right_e < $left_e) {
5127             $char[$i] = '\\' . $char[$i];
5128             }
5129 0         0 }
5130 0         0 elsif ($char[$i] eq '\u') {
5131             $char[$i] = '@{[Elatin10::ucfirst qq<';
5132             $left_e++;
5133 0         0 }
5134 0         0 elsif ($char[$i] eq '\l') {
5135             $char[$i] = '@{[Elatin10::lcfirst qq<';
5136             $left_e++;
5137 0         0 }
5138 0         0 elsif ($char[$i] eq '\U') {
5139             $char[$i] = '@{[Elatin10::uc qq<';
5140             $left_e++;
5141 0         0 }
5142 0         0 elsif ($char[$i] eq '\L') {
5143             $char[$i] = '@{[Elatin10::lc qq<';
5144             $left_e++;
5145 0         0 }
5146 0         0 elsif ($char[$i] eq '\F') {
5147             $char[$i] = '@{[Elatin10::fc qq<';
5148             $left_e++;
5149 0         0 }
5150 0         0 elsif ($char[$i] eq '\Q') {
5151             $char[$i] = '@{[CORE::quotemeta qq<';
5152             $left_e++;
5153 0 0       0 }
5154 0         0 elsif ($char[$i] eq '\E') {
5155 0         0 if ($right_e < $left_e) {
5156             $char[$i] = '>]}';
5157             $right_e++;
5158 0         0 }
5159             else {
5160             $char[$i] = '';
5161             }
5162 0         0 }
5163 0 0       0 elsif ($char[$i] eq '\Q') {
5164 0         0 while (1) {
5165             if (++$i > $#char) {
5166 0 0       0 last;
5167 0         0 }
5168             if ($char[$i] eq '\E') {
5169             last;
5170             }
5171             }
5172             }
5173             elsif ($char[$i] eq '\E') {
5174             }
5175              
5176             # $0 --> $0
5177             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5178             }
5179             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5180             }
5181              
5182             # $$ --> $$
5183             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5184             }
5185              
5186             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5187 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5188             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5189             $char[$i] = e_capture($1);
5190 0         0 }
5191             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5192             $char[$i] = e_capture($1);
5193             }
5194              
5195 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5196             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5197             $char[$i] = e_capture($1.'->'.$2);
5198             }
5199              
5200 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5201             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5202             $char[$i] = e_capture($1.'->'.$2);
5203             }
5204              
5205 0         0 # $$foo
5206             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5207             $char[$i] = e_capture($1);
5208             }
5209              
5210 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5211             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5212             $char[$i] = '@{[Elatin10::PREMATCH()]}';
5213             }
5214              
5215 8         44 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5216             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5217             $char[$i] = '@{[Elatin10::MATCH()]}';
5218             }
5219              
5220 8         43 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5221             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5222             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5223             }
5224              
5225             # ${ foo } --> ${ foo }
5226             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5227             }
5228              
5229 6         35 # ${ ... }
5230             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5231             $char[$i] = e_capture($1);
5232             }
5233             }
5234 0 50       0  
5235 93         205 # return string
5236             if ($left_e > $right_e) {
5237 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5238             }
5239             return join '', @char;
5240             }
5241              
5242             #
5243             # escape regexp (m//, qr//)
5244 93     652 0 744 #
5245 652   100     2711 sub e_qr {
5246             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5247 652         3043 $modifier ||= '';
5248 652 50       1137  
5249 652         1480 $modifier =~ tr/p//d;
5250 0         0 if ($modifier =~ /([adlu])/oxms) {
5251 0 0       0 my $line = 0;
5252 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5253 0         0 if ($filename ne __FILE__) {
5254             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5255             last;
5256 0         0 }
5257             }
5258             die qq{Unsupported modifier "$1" used at line $line.\n};
5259 0         0 }
5260              
5261             $slash = 'div';
5262 652 100       1063  
    100          
5263 652         1880 # literal null string pattern
5264 8         9 if ($string eq '') {
5265 8         10 $modifier =~ tr/bB//d;
5266             $modifier =~ tr/i//d;
5267             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5268             }
5269              
5270             # /b /B modifier
5271             elsif ($modifier =~ tr/bB//d) {
5272 8 50       39  
5273 2         6 # choice again delimiter
5274 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5275 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5276 0         0 my %octet = map {$_ => 1} @char;
5277 0         0 if (not $octet{')'}) {
5278             $delimiter = '(';
5279             $end_delimiter = ')';
5280 0         0 }
5281 0         0 elsif (not $octet{'}'}) {
5282             $delimiter = '{';
5283             $end_delimiter = '}';
5284 0         0 }
5285 0         0 elsif (not $octet{']'}) {
5286             $delimiter = '[';
5287             $end_delimiter = ']';
5288 0         0 }
5289 0         0 elsif (not $octet{'>'}) {
5290             $delimiter = '<';
5291             $end_delimiter = '>';
5292 0         0 }
5293 0 0       0 else {
5294 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5295 0         0 if (not $octet{$char}) {
5296 0         0 $delimiter = $char;
5297             $end_delimiter = $char;
5298             last;
5299             }
5300             }
5301             }
5302 0 50 33     0 }
5303 2         12  
5304             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5305             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5306 0         0 }
5307             else {
5308             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5309             }
5310 2 100       12 }
5311 642         1365  
5312             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5313             my $metachar = qr/[\@\\|[\]{^]/oxms;
5314 642         2176  
5315             # split regexp
5316             my @char = $string =~ /\G((?>
5317             [^\\\$\@\[\(] |
5318             \\x (?>[0-9A-Fa-f]{1,2}) |
5319             \\ (?>[0-7]{2,3}) |
5320             \\c [\x40-\x5F] |
5321             \\x\{ (?>[0-9A-Fa-f]+) \} |
5322             \\o\{ (?>[0-7]+) \} |
5323             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5324             \\ $q_char |
5325             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5326             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5327             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5328             [\$\@] $qq_variable |
5329             \$ (?>\s* [0-9]+) |
5330             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5331             \$ \$ (?![\w\{]) |
5332             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5333             \[\^ |
5334             \[\: (?>[a-z]+) :\] |
5335             \[\:\^ (?>[a-z]+) :\] |
5336             \(\? |
5337             $q_char
5338             ))/oxmsg;
5339 642 50       64007  
5340 642         2621 # choice again delimiter
  0         0  
5341 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5342 0         0 my %octet = map {$_ => 1} @char;
5343 0         0 if (not $octet{')'}) {
5344             $delimiter = '(';
5345             $end_delimiter = ')';
5346 0         0 }
5347 0         0 elsif (not $octet{'}'}) {
5348             $delimiter = '{';
5349             $end_delimiter = '}';
5350 0         0 }
5351 0         0 elsif (not $octet{']'}) {
5352             $delimiter = '[';
5353             $end_delimiter = ']';
5354 0         0 }
5355 0         0 elsif (not $octet{'>'}) {
5356             $delimiter = '<';
5357             $end_delimiter = '>';
5358 0         0 }
5359 0 0       0 else {
5360 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5361 0         0 if (not $octet{$char}) {
5362 0         0 $delimiter = $char;
5363             $end_delimiter = $char;
5364             last;
5365             }
5366             }
5367             }
5368 0         0 }
5369 642         990  
5370 642         889 my $left_e = 0;
5371             my $right_e = 0;
5372             for (my $i=0; $i <= $#char; $i++) {
5373 642 50 66     1520  
    50 66        
    100          
    100          
    100          
    100          
5374 1872         9478 # "\L\u" --> "\u\L"
5375             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5376             @char[$i,$i+1] = @char[$i+1,$i];
5377             }
5378              
5379 0         0 # "\U\l" --> "\l\U"
5380             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5381             @char[$i,$i+1] = @char[$i+1,$i];
5382             }
5383              
5384 0         0 # octal escape sequence
5385             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5386             $char[$i] = Elatin10::octchr($1);
5387             }
5388              
5389 1         4 # hexadecimal escape sequence
5390             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5391             $char[$i] = Elatin10::hexchr($1);
5392             }
5393              
5394             # \b{...} --> b\{...}
5395             # \B{...} --> B\{...}
5396             # \N{CHARNAME} --> N\{CHARNAME}
5397             # \p{PROPERTY} --> p\{PROPERTY}
5398 1         4 # \P{PROPERTY} --> P\{PROPERTY}
5399             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5400             $char[$i] = $1 . '\\' . $2;
5401             }
5402              
5403 6         20 # \p, \P, \X --> p, P, X
5404             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5405             $char[$i] = $1;
5406 4 100 100     10 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5407              
5408             if (0) {
5409             }
5410 1872         5364  
5411 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5412 6         111 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5413             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)) {
5414             $char[$i] .= join '', splice @char, $i+1, 3;
5415 0         0 }
5416             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)) {
5417             $char[$i] .= join '', splice @char, $i+1, 2;
5418 0         0 }
5419             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)) {
5420             $char[$i] .= join '', splice @char, $i+1, 1;
5421             }
5422             }
5423              
5424 0         0 # open character class [...]
5425             elsif ($char[$i] eq '[') {
5426             my $left = $i;
5427              
5428             # [] make die "Unmatched [] in regexp ...\n"
5429 328 100       431 # (and so on)
5430 328         720  
5431             if ($char[$i+1] eq ']') {
5432             $i++;
5433 3         6 }
5434 328 50       418  
5435 1379         1966 while (1) {
5436             if (++$i > $#char) {
5437 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5438 1379         2423 }
5439             if ($char[$i] eq ']') {
5440             my $right = $i;
5441 328 100       381  
5442 328         1561 # [...]
  30         66  
5443             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5444             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);
5445 90         135 }
5446             else {
5447             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5448 298         1223 }
5449 328         561  
5450             $i = $left;
5451             last;
5452             }
5453             }
5454             }
5455              
5456 328         796 # open character class [^...]
5457             elsif ($char[$i] eq '[^') {
5458             my $left = $i;
5459              
5460             # [^] make die "Unmatched [] in regexp ...\n"
5461 74 100       94 # (and so on)
5462 74         158  
5463             if ($char[$i+1] eq ']') {
5464             $i++;
5465 4         6 }
5466 74 50       86  
5467 272         380 while (1) {
5468             if (++$i > $#char) {
5469 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5470 272         445 }
5471             if ($char[$i] eq ']') {
5472             my $right = $i;
5473 74 100       125  
5474 74         334 # [^...]
  30         62  
5475             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5476             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);
5477 90         134 }
5478             else {
5479             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5480 44         191 }
5481 74         133  
5482             $i = $left;
5483             last;
5484             }
5485             }
5486             }
5487              
5488 74         178 # rewrite character class or escape character
5489             elsif (my $char = character_class($char[$i],$modifier)) {
5490             $char[$i] = $char;
5491             }
5492              
5493 139 50       344 # /i modifier
5494 20         35 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
5495             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
5496             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
5497 20         30 }
5498             else {
5499             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
5500             }
5501             }
5502              
5503 0 50       0 # \u \l \U \L \F \Q \E
5504 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5505             if ($right_e < $left_e) {
5506             $char[$i] = '\\' . $char[$i];
5507             }
5508 0         0 }
5509 0         0 elsif ($char[$i] eq '\u') {
5510             $char[$i] = '@{[Elatin10::ucfirst qq<';
5511             $left_e++;
5512 0         0 }
5513 0         0 elsif ($char[$i] eq '\l') {
5514             $char[$i] = '@{[Elatin10::lcfirst qq<';
5515             $left_e++;
5516 0         0 }
5517 1         2 elsif ($char[$i] eq '\U') {
5518             $char[$i] = '@{[Elatin10::uc qq<';
5519             $left_e++;
5520 1         4 }
5521 1         2 elsif ($char[$i] eq '\L') {
5522             $char[$i] = '@{[Elatin10::lc qq<';
5523             $left_e++;
5524 1         3 }
5525 18         32 elsif ($char[$i] eq '\F') {
5526             $char[$i] = '@{[Elatin10::fc qq<';
5527             $left_e++;
5528 18         37 }
5529 1         4 elsif ($char[$i] eq '\Q') {
5530             $char[$i] = '@{[CORE::quotemeta qq<';
5531             $left_e++;
5532 1 50       2 }
5533 21         41 elsif ($char[$i] eq '\E') {
5534 21         28 if ($right_e < $left_e) {
5535             $char[$i] = '>]}';
5536             $right_e++;
5537 21         41 }
5538             else {
5539             $char[$i] = '';
5540             }
5541 0         0 }
5542 0 0       0 elsif ($char[$i] eq '\Q') {
5543 0         0 while (1) {
5544             if (++$i > $#char) {
5545 0 0       0 last;
5546 0         0 }
5547             if ($char[$i] eq '\E') {
5548             last;
5549             }
5550             }
5551             }
5552             elsif ($char[$i] eq '\E') {
5553             }
5554              
5555 0 0       0 # $0 --> $0
5556 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5557             if ($ignorecase) {
5558             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5559             }
5560 0 0       0 }
5561 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5562             if ($ignorecase) {
5563             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5564             }
5565             }
5566              
5567             # $$ --> $$
5568             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5569             }
5570              
5571             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5572 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5573 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5574 0         0 $char[$i] = e_capture($1);
5575             if ($ignorecase) {
5576             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5577             }
5578 0         0 }
5579 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5580 0         0 $char[$i] = e_capture($1);
5581             if ($ignorecase) {
5582             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5583             }
5584             }
5585              
5586 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5587 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5588 0         0 $char[$i] = e_capture($1.'->'.$2);
5589             if ($ignorecase) {
5590             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5591             }
5592             }
5593              
5594 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5595 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5596 0         0 $char[$i] = e_capture($1.'->'.$2);
5597             if ($ignorecase) {
5598             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5599             }
5600             }
5601              
5602 0         0 # $$foo
5603 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5604 0         0 $char[$i] = e_capture($1);
5605             if ($ignorecase) {
5606             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5607             }
5608             }
5609              
5610 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
5611 8         25 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5612             if ($ignorecase) {
5613             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
5614 0         0 }
5615             else {
5616             $char[$i] = '@{[Elatin10::PREMATCH()]}';
5617             }
5618             }
5619              
5620 8 50       20 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
5621 8         22 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5622             if ($ignorecase) {
5623             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
5624 0         0 }
5625             else {
5626             $char[$i] = '@{[Elatin10::MATCH()]}';
5627             }
5628             }
5629              
5630 8 50       25 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
5631 6         16 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5632             if ($ignorecase) {
5633             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
5634 0         0 }
5635             else {
5636             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
5637             }
5638             }
5639              
5640 6 0       17 # ${ foo }
5641 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5642             if ($ignorecase) {
5643             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5644             }
5645             }
5646              
5647 0         0 # ${ ... }
5648 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5649 0         0 $char[$i] = e_capture($1);
5650             if ($ignorecase) {
5651             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5652             }
5653             }
5654              
5655 0         0 # $scalar or @array
5656 21 100       54 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5657 21         56 $char[$i] = e_string($char[$i]);
5658             if ($ignorecase) {
5659             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
5660             }
5661             }
5662              
5663 11 100 33     32 # quote character before ? + * {
    50          
5664             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5665             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
5666 138         982 }
5667 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5668 0         0 my $char = $char[$i-1];
5669             if ($char[$i] eq '{') {
5670             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5671 0         0 }
5672             else {
5673             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5674             }
5675 0         0 }
5676             else {
5677             $char[$i-1] = '(?:' . $char[$i-1] . ')';
5678             }
5679             }
5680             }
5681 127         478  
5682 642 50       1144 # make regexp string
5683 642 0 0     1303 $modifier =~ tr/i//d;
5684 0         0 if ($left_e > $right_e) {
5685             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5686             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5687 0         0 }
5688             else {
5689             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5690 0 50 33     0 }
5691 642         3341 }
5692             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5693             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5694 0         0 }
5695             else {
5696             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5697             }
5698             }
5699              
5700             #
5701             # double quote stuff
5702 642     180 0 5058 #
5703             sub qq_stuff {
5704             my($delimiter,$end_delimiter,$stuff) = @_;
5705 180 100       249  
5706 180         343 # scalar variable or array variable
5707             if ($stuff =~ /\A [\$\@] /oxms) {
5708             return $stuff;
5709             }
5710 100         328  
  80         172  
5711 80         217 # quote by delimiter
5712 80 50       180 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
5713 80 50       130 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5714 80 50       105 next if $char eq $delimiter;
5715 80         137 next if $char eq $end_delimiter;
5716             if (not $octet{$char}) {
5717             return join '', 'qq', $char, $stuff, $char;
5718 80         365 }
5719             }
5720             return join '', 'qq', '<', $stuff, '>';
5721             }
5722              
5723             #
5724             # escape regexp (m'', qr'', and m''b, qr''b)
5725 0     10 0 0 #
5726 10   50     40 sub e_qr_q {
5727             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5728 10         41 $modifier ||= '';
5729 10 50       14  
5730 10         19 $modifier =~ tr/p//d;
5731 0         0 if ($modifier =~ /([adlu])/oxms) {
5732 0 0       0 my $line = 0;
5733 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5734 0         0 if ($filename ne __FILE__) {
5735             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5736             last;
5737 0         0 }
5738             }
5739             die qq{Unsupported modifier "$1" used at line $line.\n};
5740 0         0 }
5741              
5742             $slash = 'div';
5743 10 100       14  
    50          
5744 10         19 # literal null string pattern
5745 8         10 if ($string eq '') {
5746 8         8 $modifier =~ tr/bB//d;
5747             $modifier =~ tr/i//d;
5748             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5749             }
5750              
5751 8         36 # with /b /B modifier
5752             elsif ($modifier =~ tr/bB//d) {
5753             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5754             }
5755              
5756 0         0 # without /b /B modifier
5757             else {
5758             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5759             }
5760             }
5761              
5762             #
5763             # escape regexp (m'', qr'')
5764 2     2 0 7 #
5765             sub e_qr_qt {
5766 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5767              
5768             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5769 2         6  
5770             # split regexp
5771             my @char = $string =~ /\G((?>
5772             [^\\\[\$\@\/] |
5773             [\x00-\xFF] |
5774             \[\^ |
5775             \[\: (?>[a-z]+) \:\] |
5776             \[\:\^ (?>[a-z]+) \:\] |
5777             [\$\@\/] |
5778             \\ (?:$q_char) |
5779             (?:$q_char)
5780             ))/oxmsg;
5781 2         64  
5782 2 50 33     7 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
5783             for (my $i=0; $i <= $#char; $i++) {
5784             if (0) {
5785             }
5786 2         16  
5787 0         0 # open character class [...]
5788 0 0       0 elsif ($char[$i] eq '[') {
5789 0         0 my $left = $i;
5790             if ($char[$i+1] eq ']') {
5791 0         0 $i++;
5792 0 0       0 }
5793 0         0 while (1) {
5794             if (++$i > $#char) {
5795 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
5796 0         0 }
5797             if ($char[$i] eq ']') {
5798             my $right = $i;
5799 0         0  
5800             # [...]
5801 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5802 0         0  
5803             $i = $left;
5804             last;
5805             }
5806             }
5807             }
5808              
5809 0         0 # open character class [^...]
5810 0 0       0 elsif ($char[$i] eq '[^') {
5811 0         0 my $left = $i;
5812             if ($char[$i+1] eq ']') {
5813 0         0 $i++;
5814 0 0       0 }
5815 0         0 while (1) {
5816             if (++$i > $#char) {
5817 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
5818 0         0 }
5819             if ($char[$i] eq ']') {
5820             my $right = $i;
5821 0         0  
5822             # [^...]
5823 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5824 0         0  
5825             $i = $left;
5826             last;
5827             }
5828             }
5829             }
5830              
5831 0         0 # escape $ @ / and \
5832             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5833             $char[$i] = '\\' . $char[$i];
5834             }
5835              
5836 0         0 # rewrite character class or escape character
5837             elsif (my $char = character_class($char[$i],$modifier)) {
5838             $char[$i] = $char;
5839             }
5840              
5841 0 0       0 # /i modifier
5842 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
5843             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
5844             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
5845 0         0 }
5846             else {
5847             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
5848             }
5849             }
5850              
5851 0 0       0 # quote character before ? + * {
5852             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5853             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
5854 0         0 }
5855             else {
5856             $char[$i-1] = '(?:' . $char[$i-1] . ')';
5857             }
5858             }
5859 0         0 }
5860 2         6  
5861             $delimiter = '/';
5862 2         2 $end_delimiter = '/';
5863 2         3  
5864             $modifier =~ tr/i//d;
5865             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5866             }
5867              
5868             #
5869             # escape regexp (m''b, qr''b)
5870 2     0 0 15 #
5871             sub e_qr_qb {
5872             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5873 0         0  
5874             # split regexp
5875             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
5876 0         0  
5877 0 0       0 # unescape character
    0          
5878             for (my $i=0; $i <= $#char; $i++) {
5879             if (0) {
5880             }
5881 0         0  
5882             # remain \\
5883             elsif ($char[$i] eq '\\\\') {
5884             }
5885              
5886 0         0 # escape $ @ / and \
5887             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5888             $char[$i] = '\\' . $char[$i];
5889             }
5890 0         0 }
5891 0         0  
5892 0         0 $delimiter = '/';
5893             $end_delimiter = '/';
5894             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5895             }
5896              
5897             #
5898             # escape regexp (s/here//)
5899 0     76 0 0 #
5900 76   100     226 sub e_s1 {
5901             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5902 76         305 $modifier ||= '';
5903 76 50       117  
5904 76         185 $modifier =~ tr/p//d;
5905 0         0 if ($modifier =~ /([adlu])/oxms) {
5906 0 0       0 my $line = 0;
5907 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5908 0         0 if ($filename ne __FILE__) {
5909             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5910             last;
5911 0         0 }
5912             }
5913             die qq{Unsupported modifier "$1" used at line $line.\n};
5914 0         0 }
5915              
5916             $slash = 'div';
5917 76 100       135  
    50          
5918 76         375 # literal null string pattern
5919 8         9 if ($string eq '') {
5920 8         8 $modifier =~ tr/bB//d;
5921             $modifier =~ tr/i//d;
5922             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5923             }
5924              
5925             # /b /B modifier
5926             elsif ($modifier =~ tr/bB//d) {
5927 8 0       67  
5928 0         0 # choice again delimiter
5929 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5930 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5931 0         0 my %octet = map {$_ => 1} @char;
5932 0         0 if (not $octet{')'}) {
5933             $delimiter = '(';
5934             $end_delimiter = ')';
5935 0         0 }
5936 0         0 elsif (not $octet{'}'}) {
5937             $delimiter = '{';
5938             $end_delimiter = '}';
5939 0         0 }
5940 0         0 elsif (not $octet{']'}) {
5941             $delimiter = '[';
5942             $end_delimiter = ']';
5943 0         0 }
5944 0         0 elsif (not $octet{'>'}) {
5945             $delimiter = '<';
5946             $end_delimiter = '>';
5947 0         0 }
5948 0 0       0 else {
5949 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5950 0         0 if (not $octet{$char}) {
5951 0         0 $delimiter = $char;
5952             $end_delimiter = $char;
5953             last;
5954             }
5955             }
5956             }
5957 0         0 }
5958 0         0  
5959             my $prematch = '';
5960             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5961 0 100       0 }
5962 68         192  
5963             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5964             my $metachar = qr/[\@\\|[\]{^]/oxms;
5965 68         267  
5966             # split regexp
5967             my @char = $string =~ /\G((?>
5968             [^\\\$\@\[\(] |
5969             \\ (?>[1-9][0-9]*) |
5970             \\g (?>\s*) (?>[1-9][0-9]*) |
5971             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
5972             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
5973             \\x (?>[0-9A-Fa-f]{1,2}) |
5974             \\ (?>[0-7]{2,3}) |
5975             \\c [\x40-\x5F] |
5976             \\x\{ (?>[0-9A-Fa-f]+) \} |
5977             \\o\{ (?>[0-7]+) \} |
5978             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5979             \\ $q_char |
5980             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5981             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5982             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5983             [\$\@] $qq_variable |
5984             \$ (?>\s* [0-9]+) |
5985             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5986             \$ \$ (?![\w\{]) |
5987             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5988             \[\^ |
5989             \[\: (?>[a-z]+) :\] |
5990             \[\:\^ (?>[a-z]+) :\] |
5991             \(\? |
5992             $q_char
5993             ))/oxmsg;
5994 68 50       15724  
5995 68         514 # choice again delimiter
  0         0  
5996 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5997 0         0 my %octet = map {$_ => 1} @char;
5998 0         0 if (not $octet{')'}) {
5999             $delimiter = '(';
6000             $end_delimiter = ')';
6001 0         0 }
6002 0         0 elsif (not $octet{'}'}) {
6003             $delimiter = '{';
6004             $end_delimiter = '}';
6005 0         0 }
6006 0         0 elsif (not $octet{']'}) {
6007             $delimiter = '[';
6008             $end_delimiter = ']';
6009 0         0 }
6010 0         0 elsif (not $octet{'>'}) {
6011             $delimiter = '<';
6012             $end_delimiter = '>';
6013 0         0 }
6014 0 0       0 else {
6015 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6016 0         0 if (not $octet{$char}) {
6017 0         0 $delimiter = $char;
6018             $end_delimiter = $char;
6019             last;
6020             }
6021             }
6022             }
6023             }
6024 0         0  
  68         148  
6025             # count '('
6026 253         487 my $parens = grep { $_ eq '(' } @char;
6027 68         100  
6028 68         96 my $left_e = 0;
6029             my $right_e = 0;
6030             for (my $i=0; $i <= $#char; $i++) {
6031 68 50 33     198  
    50 33        
    100          
    100          
    50          
    50          
6032 195         1078 # "\L\u" --> "\u\L"
6033             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6034             @char[$i,$i+1] = @char[$i+1,$i];
6035             }
6036              
6037 0         0 # "\U\l" --> "\l\U"
6038             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6039             @char[$i,$i+1] = @char[$i+1,$i];
6040             }
6041              
6042 0         0 # octal escape sequence
6043             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6044             $char[$i] = Elatin10::octchr($1);
6045             }
6046              
6047 1         3 # hexadecimal escape sequence
6048             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6049             $char[$i] = Elatin10::hexchr($1);
6050             }
6051              
6052             # \b{...} --> b\{...}
6053             # \B{...} --> B\{...}
6054             # \N{CHARNAME} --> N\{CHARNAME}
6055             # \p{PROPERTY} --> p\{PROPERTY}
6056 1         4 # \P{PROPERTY} --> P\{PROPERTY}
6057             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6058             $char[$i] = $1 . '\\' . $2;
6059             }
6060              
6061 0         0 # \p, \P, \X --> p, P, X
6062             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6063             $char[$i] = $1;
6064 0 50 66     0 }
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6065              
6066             if (0) {
6067             }
6068 195         782  
6069 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6070 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6071             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)) {
6072             $char[$i] .= join '', splice @char, $i+1, 3;
6073 0         0 }
6074             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)) {
6075             $char[$i] .= join '', splice @char, $i+1, 2;
6076 0         0 }
6077             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)) {
6078             $char[$i] .= join '', splice @char, $i+1, 1;
6079             }
6080             }
6081              
6082 0         0 # open character class [...]
6083 13 50       20 elsif ($char[$i] eq '[') {
6084 13         140 my $left = $i;
6085             if ($char[$i+1] eq ']') {
6086 0         0 $i++;
6087 13 50       18 }
6088 58         97 while (1) {
6089             if (++$i > $#char) {
6090 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6091 58         115 }
6092             if ($char[$i] eq ']') {
6093             my $right = $i;
6094 13 50       21  
6095 13         176 # [...]
  0         0  
6096             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6097             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);
6098 0         0 }
6099             else {
6100             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6101 13         61 }
6102 13         31  
6103             $i = $left;
6104             last;
6105             }
6106             }
6107             }
6108              
6109 13         33 # open character class [^...]
6110 0 0       0 elsif ($char[$i] eq '[^') {
6111 0         0 my $left = $i;
6112             if ($char[$i+1] eq ']') {
6113 0         0 $i++;
6114 0 0       0 }
6115 0         0 while (1) {
6116             if (++$i > $#char) {
6117 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6118 0         0 }
6119             if ($char[$i] eq ']') {
6120             my $right = $i;
6121 0 0       0  
6122 0         0 # [^...]
  0         0  
6123             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6124             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);
6125 0         0 }
6126             else {
6127             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6128 0         0 }
6129 0         0  
6130             $i = $left;
6131             last;
6132             }
6133             }
6134             }
6135              
6136 0         0 # rewrite character class or escape character
6137             elsif (my $char = character_class($char[$i],$modifier)) {
6138             $char[$i] = $char;
6139             }
6140              
6141 7 50       12 # /i modifier
6142 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6143             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6144             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6145 3         4 }
6146             else {
6147             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6148             }
6149             }
6150              
6151 0 0       0 # \u \l \U \L \F \Q \E
6152 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6153             if ($right_e < $left_e) {
6154             $char[$i] = '\\' . $char[$i];
6155             }
6156 0         0 }
6157 0         0 elsif ($char[$i] eq '\u') {
6158             $char[$i] = '@{[Elatin10::ucfirst qq<';
6159             $left_e++;
6160 0         0 }
6161 0         0 elsif ($char[$i] eq '\l') {
6162             $char[$i] = '@{[Elatin10::lcfirst qq<';
6163             $left_e++;
6164 0         0 }
6165 0         0 elsif ($char[$i] eq '\U') {
6166             $char[$i] = '@{[Elatin10::uc qq<';
6167             $left_e++;
6168 0         0 }
6169 0         0 elsif ($char[$i] eq '\L') {
6170             $char[$i] = '@{[Elatin10::lc qq<';
6171             $left_e++;
6172 0         0 }
6173 0         0 elsif ($char[$i] eq '\F') {
6174             $char[$i] = '@{[Elatin10::fc qq<';
6175             $left_e++;
6176 0         0 }
6177 0         0 elsif ($char[$i] eq '\Q') {
6178             $char[$i] = '@{[CORE::quotemeta qq<';
6179             $left_e++;
6180 0 0       0 }
6181 0         0 elsif ($char[$i] eq '\E') {
6182 0         0 if ($right_e < $left_e) {
6183             $char[$i] = '>]}';
6184             $right_e++;
6185 0         0 }
6186             else {
6187             $char[$i] = '';
6188             }
6189 0         0 }
6190 0 0       0 elsif ($char[$i] eq '\Q') {
6191 0         0 while (1) {
6192             if (++$i > $#char) {
6193 0 0       0 last;
6194 0         0 }
6195             if ($char[$i] eq '\E') {
6196             last;
6197             }
6198             }
6199             }
6200             elsif ($char[$i] eq '\E') {
6201             }
6202              
6203             # \0 --> \0
6204             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6205             }
6206              
6207             # \g{N}, \g{-N}
6208              
6209             # P.108 Using Simple Patterns
6210             # in Chapter 7: In the World of Regular Expressions
6211             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6212              
6213             # P.221 Capturing
6214             # in Chapter 5: Pattern Matching
6215             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6216              
6217             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6218             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6219             }
6220              
6221             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6222             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6223             }
6224              
6225             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6226             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6227             }
6228              
6229             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6230             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6231             }
6232              
6233 0 0       0 # $0 --> $0
6234 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6235             if ($ignorecase) {
6236             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6237             }
6238 0 0       0 }
6239 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6240             if ($ignorecase) {
6241             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6242             }
6243             }
6244              
6245             # $$ --> $$
6246             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6247             }
6248              
6249             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6250 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6251 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6252 0         0 $char[$i] = e_capture($1);
6253             if ($ignorecase) {
6254             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6255             }
6256 0         0 }
6257 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6258 0         0 $char[$i] = e_capture($1);
6259             if ($ignorecase) {
6260             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6261             }
6262             }
6263              
6264 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6265 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6266 0         0 $char[$i] = e_capture($1.'->'.$2);
6267             if ($ignorecase) {
6268             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6269             }
6270             }
6271              
6272 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6273 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6274 0         0 $char[$i] = e_capture($1.'->'.$2);
6275             if ($ignorecase) {
6276             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6277             }
6278             }
6279              
6280 0         0 # $$foo
6281 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6282 0         0 $char[$i] = e_capture($1);
6283             if ($ignorecase) {
6284             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6285             }
6286             }
6287              
6288 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
6289 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6290             if ($ignorecase) {
6291             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
6292 0         0 }
6293             else {
6294             $char[$i] = '@{[Elatin10::PREMATCH()]}';
6295             }
6296             }
6297              
6298 4 50       13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
6299 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6300             if ($ignorecase) {
6301             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
6302 0         0 }
6303             else {
6304             $char[$i] = '@{[Elatin10::MATCH()]}';
6305             }
6306             }
6307              
6308 4 50       14 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
6309 3         9 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6310             if ($ignorecase) {
6311             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
6312 0         0 }
6313             else {
6314             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
6315             }
6316             }
6317              
6318 3 0       11 # ${ foo }
6319 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6320             if ($ignorecase) {
6321             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6322             }
6323             }
6324              
6325 0         0 # ${ ... }
6326 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6327 0         0 $char[$i] = e_capture($1);
6328             if ($ignorecase) {
6329             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6330             }
6331             }
6332              
6333 0         0 # $scalar or @array
6334 4 50       15 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6335 4         27 $char[$i] = e_string($char[$i]);
6336             if ($ignorecase) {
6337             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6338             }
6339             }
6340              
6341 0 50       0 # quote character before ? + * {
6342             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6343             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6344 13         66 }
6345             else {
6346             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6347             }
6348             }
6349             }
6350 13         67  
6351 68         153 # make regexp string
6352 68 50       116 my $prematch = '';
6353 68         253 $modifier =~ tr/i//d;
6354             if ($left_e > $right_e) {
6355 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6356             }
6357             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6358             }
6359              
6360             #
6361             # escape regexp (s'here'' or s'here''b)
6362 68     21 0 713 #
6363 21   100     43 sub e_s1_q {
6364             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6365 21         79 $modifier ||= '';
6366 21 50       23  
6367 21         48 $modifier =~ tr/p//d;
6368 0         0 if ($modifier =~ /([adlu])/oxms) {
6369 0 0       0 my $line = 0;
6370 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6371 0         0 if ($filename ne __FILE__) {
6372             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6373             last;
6374 0         0 }
6375             }
6376             die qq{Unsupported modifier "$1" used at line $line.\n};
6377 0         0 }
6378              
6379             $slash = 'div';
6380 21 100       32  
    50          
6381 21         72 # literal null string pattern
6382 8         8 if ($string eq '') {
6383 8         9 $modifier =~ tr/bB//d;
6384             $modifier =~ tr/i//d;
6385             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6386             }
6387              
6388 8         46 # with /b /B modifier
6389             elsif ($modifier =~ tr/bB//d) {
6390             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6391             }
6392              
6393 0         0 # without /b /B modifier
6394             else {
6395             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6396             }
6397             }
6398              
6399             #
6400             # escape regexp (s'here'')
6401 13     13 0 33 #
6402             sub e_s1_qt {
6403 13 50       25 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6404              
6405             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6406 13         24  
6407             # split regexp
6408             my @char = $string =~ /\G((?>
6409             [^\\\[\$\@\/] |
6410             [\x00-\xFF] |
6411             \[\^ |
6412             \[\: (?>[a-z]+) \:\] |
6413             \[\:\^ (?>[a-z]+) \:\] |
6414             [\$\@\/] |
6415             \\ (?:$q_char) |
6416             (?:$q_char)
6417             ))/oxmsg;
6418 13         211  
6419 13 50 33     40 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6420             for (my $i=0; $i <= $#char; $i++) {
6421             if (0) {
6422             }
6423 25         122  
6424 0         0 # open character class [...]
6425 0 0       0 elsif ($char[$i] eq '[') {
6426 0         0 my $left = $i;
6427             if ($char[$i+1] eq ']') {
6428 0         0 $i++;
6429 0 0       0 }
6430 0         0 while (1) {
6431             if (++$i > $#char) {
6432 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6433 0         0 }
6434             if ($char[$i] eq ']') {
6435             my $right = $i;
6436 0         0  
6437             # [...]
6438 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6439 0         0  
6440             $i = $left;
6441             last;
6442             }
6443             }
6444             }
6445              
6446 0         0 # open character class [^...]
6447 0 0       0 elsif ($char[$i] eq '[^') {
6448 0         0 my $left = $i;
6449             if ($char[$i+1] eq ']') {
6450 0         0 $i++;
6451 0 0       0 }
6452 0         0 while (1) {
6453             if (++$i > $#char) {
6454 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6455 0         0 }
6456             if ($char[$i] eq ']') {
6457             my $right = $i;
6458 0         0  
6459             # [^...]
6460 0         0 splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6461 0         0  
6462             $i = $left;
6463             last;
6464             }
6465             }
6466             }
6467              
6468 0         0 # escape $ @ / and \
6469             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6470             $char[$i] = '\\' . $char[$i];
6471             }
6472              
6473 0         0 # rewrite character class or escape character
6474             elsif (my $char = character_class($char[$i],$modifier)) {
6475             $char[$i] = $char;
6476             }
6477              
6478 6 0       13 # /i modifier
6479 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6480             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6481             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6482 0         0 }
6483             else {
6484             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6485             }
6486             }
6487              
6488 0 0       0 # quote character before ? + * {
6489             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6490             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6491 0         0 }
6492             else {
6493             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6494             }
6495             }
6496 0         0 }
6497 13         21  
6498 13         21 $modifier =~ tr/i//d;
6499 13         15 $delimiter = '/';
6500 13         17 $end_delimiter = '/';
6501             my $prematch = '';
6502             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6503             }
6504              
6505             #
6506             # escape regexp (s'here''b)
6507 13     0 0 90 #
6508             sub e_s1_qb {
6509             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6510 0         0  
6511             # split regexp
6512             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6513 0         0  
6514 0 0       0 # unescape character
    0          
6515             for (my $i=0; $i <= $#char; $i++) {
6516             if (0) {
6517             }
6518 0         0  
6519             # remain \\
6520             elsif ($char[$i] eq '\\\\') {
6521             }
6522              
6523 0         0 # escape $ @ / and \
6524             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6525             $char[$i] = '\\' . $char[$i];
6526             }
6527 0         0 }
6528 0         0  
6529 0         0 $delimiter = '/';
6530 0         0 $end_delimiter = '/';
6531             my $prematch = '';
6532             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6533             }
6534              
6535             #
6536             # escape regexp (s''here')
6537 0     16 0 0 #
6538             sub e_s2_q {
6539 16         29 my($ope,$delimiter,$end_delimiter,$string) = @_;
6540              
6541 16         19 $slash = 'div';
6542 16         91  
6543 16 100       39 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
6544             for (my $i=0; $i <= $#char; $i++) {
6545             if (0) {
6546             }
6547 9         29  
6548             # not escape \\
6549             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6550             }
6551              
6552 0         0 # escape $ @ / and \
6553             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6554             $char[$i] = '\\' . $char[$i];
6555             }
6556 5         13 }
6557              
6558             return join '', $ope, $delimiter, @char, $end_delimiter;
6559             }
6560              
6561             #
6562             # escape regexp (s/here/and here/modifier)
6563 16     97 0 50 #
6564 97   100     681 sub e_sub {
6565             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6566 97         408 $modifier ||= '';
6567 97 50       180  
6568 97         246 $modifier =~ tr/p//d;
6569 0         0 if ($modifier =~ /([adlu])/oxms) {
6570 0 0       0 my $line = 0;
6571 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6572 0         0 if ($filename ne __FILE__) {
6573             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6574             last;
6575 0         0 }
6576             }
6577             die qq{Unsupported modifier "$1" used at line $line.\n};
6578 0 100       0 }
6579 97         258  
6580 36         47 if ($variable eq '') {
6581             $variable = '$_';
6582             $bind_operator = ' =~ ';
6583 36         71 }
6584              
6585             $slash = 'div';
6586              
6587             # P.128 Start of match (or end of previous match): \G
6588             # P.130 Advanced Use of \G with Perl
6589             # in Chapter 3: Overview of Regular Expression Features and Flavors
6590             # P.312 Iterative Matching: Scalar Context, with /g
6591             # in Chapter 7: Perl
6592             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6593              
6594             # P.181 Where You Left Off: The \G Assertion
6595             # in Chapter 5: Pattern Matching
6596             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6597              
6598             # P.220 Where You Left Off: The \G Assertion
6599             # in Chapter 5: Pattern Matching
6600 97         154 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6601 97         193  
6602             my $e_modifier = $modifier =~ tr/e//d;
6603 97         152 my $r_modifier = $modifier =~ tr/r//d;
6604 97 50       133  
6605 97         239 my $my = '';
6606 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6607 0         0 $my = $variable;
6608             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6609             $variable =~ s/ = .+ \z//oxms;
6610 0         0 }
6611 97         235  
6612             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6613             $variable_basename =~ s/ \s+ \z//oxms;
6614 97         175  
6615 97 100       136 # quote replacement string
6616 97         237 my $e_replacement = '';
6617 17         33 if ($e_modifier >= 1) {
6618             $e_replacement = e_qq('', '', '', $replacement);
6619             $e_modifier--;
6620 17 100       27 }
6621 80         202 else {
6622             if ($delimiter2 eq "'") {
6623             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6624 16         30 }
6625             else {
6626             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6627             }
6628 64         162 }
6629              
6630             my $sub = '';
6631 97 100       160  
6632 97 100       201 # with /r
6633             if ($r_modifier) {
6634             if (0) {
6635             }
6636 8         19  
6637 0 50       0 # s///gr without multibyte anchoring
6638             elsif ($modifier =~ /g/oxms) {
6639             $sub = sprintf(
6640             # 1 2 3 4 5
6641             q,
6642              
6643             $variable, # 1
6644             ($delimiter1 eq "'") ? # 2
6645             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6646             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6647             $s_matched, # 3
6648             $e_replacement, # 4
6649             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
6650             );
6651             }
6652              
6653             # s///r
6654 4         13 else {
6655              
6656 4 50       5 my $prematch = q{$`};
6657              
6658             $sub = sprintf(
6659             # 1 2 3 4 5 6 7
6660             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s"%s$Elatin10::re_r$'" } : %s>,
6661              
6662             $variable, # 1
6663             ($delimiter1 eq "'") ? # 2
6664             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6665             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6666             $s_matched, # 3
6667             $e_replacement, # 4
6668             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
6669             $prematch, # 6
6670             $variable, # 7
6671             );
6672             }
6673 4 50       10  
6674 8         23 # $var !~ s///r doesn't make sense
6675             if ($bind_operator =~ / !~ /oxms) {
6676             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6677             }
6678             }
6679              
6680 0 100       0 # without /r
6681             else {
6682             if (0) {
6683             }
6684 89         201  
6685 0 100       0 # s///g without multibyte anchoring
    100          
6686             elsif ($modifier =~ /g/oxms) {
6687             $sub = sprintf(
6688             # 1 2 3 4 5 6 7 8
6689             q,
6690              
6691             $variable, # 1
6692             ($delimiter1 eq "'") ? # 2
6693             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6694             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6695             $s_matched, # 3
6696             $e_replacement, # 4
6697             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 5
6698             $variable, # 6
6699             $variable, # 7
6700             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6701             );
6702             }
6703              
6704             # s///
6705 22         74 else {
6706              
6707 67 100       107 my $prematch = q{$`};
    100          
6708              
6709             $sub = sprintf(
6710              
6711             ($bind_operator =~ / =~ /oxms) ?
6712              
6713             # 1 2 3 4 5 6 7 8
6714             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s%s="%s$Elatin10::re_r$'"; 1 } : undef> :
6715              
6716             # 1 2 3 4 5 6 7 8
6717             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin10::re_r=%s; %s%s="%s$Elatin10::re_r$'"; undef }>,
6718              
6719             $variable, # 1
6720             $bind_operator, # 2
6721             ($delimiter1 eq "'") ? # 3
6722             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6723             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6724             $s_matched, # 4
6725             $e_replacement, # 5
6726             '$Elatin10::re_r=CORE::eval $Elatin10::re_r; ' x $e_modifier, # 6
6727             $variable, # 7
6728             $prematch, # 8
6729             );
6730             }
6731             }
6732 67 50       406  
6733 97         267 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6734             if ($my ne '') {
6735             $sub = "($my, $sub)[1]";
6736             }
6737 0         0  
6738 97         154 # clear s/// variable
6739             $sub_variable = '';
6740 97         143 $bind_operator = '';
6741              
6742             return $sub;
6743             }
6744              
6745             #
6746             # escape regexp of split qr//
6747 97     74 0 629 #
6748 74   100     331 sub e_split {
6749             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6750 74         332 $modifier ||= '';
6751 74 50       131  
6752 74         328 $modifier =~ tr/p//d;
6753 0         0 if ($modifier =~ /([adlu])/oxms) {
6754 0 0       0 my $line = 0;
6755 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6756 0         0 if ($filename ne __FILE__) {
6757             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6758             last;
6759 0         0 }
6760             }
6761             die qq{Unsupported modifier "$1" used at line $line.\n};
6762 0         0 }
6763              
6764             $slash = 'div';
6765 74 50       189  
6766 74         152 # /b /B modifier
6767             if ($modifier =~ tr/bB//d) {
6768             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6769 0 50       0 }
6770 74         159  
6771             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6772             my $metachar = qr/[\@\\|[\]{^]/oxms;
6773 74         305  
6774             # split regexp
6775             my @char = $string =~ /\G((?>
6776             [^\\\$\@\[\(] |
6777             \\x (?>[0-9A-Fa-f]{1,2}) |
6778             \\ (?>[0-7]{2,3}) |
6779             \\c [\x40-\x5F] |
6780             \\x\{ (?>[0-9A-Fa-f]+) \} |
6781             \\o\{ (?>[0-7]+) \} |
6782             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6783             \\ $q_char |
6784             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6785             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6786             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6787             [\$\@] $qq_variable |
6788             \$ (?>\s* [0-9]+) |
6789             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6790             \$ \$ (?![\w\{]) |
6791             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6792             \[\^ |
6793             \[\: (?>[a-z]+) :\] |
6794             \[\:\^ (?>[a-z]+) :\] |
6795             \(\? |
6796             $q_char
6797 74         8711 ))/oxmsg;
6798 74         235  
6799 74         101 my $left_e = 0;
6800             my $right_e = 0;
6801             for (my $i=0; $i <= $#char; $i++) {
6802 74 50 33     317  
    50 33        
    100          
    100          
    50          
    50          
6803 249         1193 # "\L\u" --> "\u\L"
6804             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6805             @char[$i,$i+1] = @char[$i+1,$i];
6806             }
6807              
6808 0         0 # "\U\l" --> "\l\U"
6809             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6810             @char[$i,$i+1] = @char[$i+1,$i];
6811             }
6812              
6813 0         0 # octal escape sequence
6814             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6815             $char[$i] = Elatin10::octchr($1);
6816             }
6817              
6818 1         4 # hexadecimal escape sequence
6819             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6820             $char[$i] = Elatin10::hexchr($1);
6821             }
6822              
6823             # \b{...} --> b\{...}
6824             # \B{...} --> B\{...}
6825             # \N{CHARNAME} --> N\{CHARNAME}
6826             # \p{PROPERTY} --> p\{PROPERTY}
6827 1         4 # \P{PROPERTY} --> P\{PROPERTY}
6828             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6829             $char[$i] = $1 . '\\' . $2;
6830             }
6831              
6832 0         0 # \p, \P, \X --> p, P, X
6833             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6834             $char[$i] = $1;
6835 0 50 100     0 }
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6836              
6837             if (0) {
6838             }
6839 249         759  
6840 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6841 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6842             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)) {
6843             $char[$i] .= join '', splice @char, $i+1, 3;
6844 0         0 }
6845             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)) {
6846             $char[$i] .= join '', splice @char, $i+1, 2;
6847 0         0 }
6848             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)) {
6849             $char[$i] .= join '', splice @char, $i+1, 1;
6850             }
6851             }
6852              
6853 0         0 # open character class [...]
6854 3 50       5 elsif ($char[$i] eq '[') {
6855 3         10 my $left = $i;
6856             if ($char[$i+1] eq ']') {
6857 0         0 $i++;
6858 3 50       4 }
6859 7         11 while (1) {
6860             if (++$i > $#char) {
6861 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6862 7         13 }
6863             if ($char[$i] eq ']') {
6864             my $right = $i;
6865 3 50       5  
6866 3         14 # [...]
  0         0  
6867             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6868             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);
6869 0         0 }
6870             else {
6871             splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6872 3         12 }
6873 3         5  
6874             $i = $left;
6875             last;
6876             }
6877             }
6878             }
6879              
6880 3         6 # open character class [^...]
6881 0 0       0 elsif ($char[$i] eq '[^') {
6882 0         0 my $left = $i;
6883             if ($char[$i+1] eq ']') {
6884 0         0 $i++;
6885 0 0       0 }
6886 0         0 while (1) {
6887             if (++$i > $#char) {
6888 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6889 0         0 }
6890             if ($char[$i] eq ']') {
6891             my $right = $i;
6892 0 0       0  
6893 0         0 # [^...]
  0         0  
6894             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6895             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);
6896 0         0 }
6897             else {
6898             splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6899 0         0 }
6900 0         0  
6901             $i = $left;
6902             last;
6903             }
6904             }
6905             }
6906              
6907 0         0 # rewrite character class or escape character
6908             elsif (my $char = character_class($char[$i],$modifier)) {
6909             $char[$i] = $char;
6910             }
6911              
6912             # P.794 29.2.161. split
6913             # in Chapter 29: Functions
6914             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6915              
6916             # P.951 split
6917             # in Chapter 27: Functions
6918             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6919              
6920             # said "The //m modifier is assumed when you split on the pattern /^/",
6921             # but perl5.008 is not so. Therefore, this software adds //m.
6922             # (and so on)
6923              
6924 1         3 # split(m/^/) --> split(m/^/m)
6925             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
6926             $modifier .= 'm';
6927             }
6928              
6929 7 0       23 # /i modifier
6930 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
6931             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
6932             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
6933 0         0 }
6934             else {
6935             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
6936             }
6937             }
6938              
6939 0 0       0 # \u \l \U \L \F \Q \E
6940 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
6941             if ($right_e < $left_e) {
6942             $char[$i] = '\\' . $char[$i];
6943             }
6944 0         0 }
6945 0         0 elsif ($char[$i] eq '\u') {
6946             $char[$i] = '@{[Elatin10::ucfirst qq<';
6947             $left_e++;
6948 0         0 }
6949 0         0 elsif ($char[$i] eq '\l') {
6950             $char[$i] = '@{[Elatin10::lcfirst qq<';
6951             $left_e++;
6952 0         0 }
6953 0         0 elsif ($char[$i] eq '\U') {
6954             $char[$i] = '@{[Elatin10::uc qq<';
6955             $left_e++;
6956 0         0 }
6957 0         0 elsif ($char[$i] eq '\L') {
6958             $char[$i] = '@{[Elatin10::lc qq<';
6959             $left_e++;
6960 0         0 }
6961 0         0 elsif ($char[$i] eq '\F') {
6962             $char[$i] = '@{[Elatin10::fc qq<';
6963             $left_e++;
6964 0         0 }
6965 0         0 elsif ($char[$i] eq '\Q') {
6966             $char[$i] = '@{[CORE::quotemeta qq<';
6967             $left_e++;
6968 0 0       0 }
6969 0         0 elsif ($char[$i] eq '\E') {
6970 0         0 if ($right_e < $left_e) {
6971             $char[$i] = '>]}';
6972             $right_e++;
6973 0         0 }
6974             else {
6975             $char[$i] = '';
6976             }
6977 0         0 }
6978 0 0       0 elsif ($char[$i] eq '\Q') {
6979 0         0 while (1) {
6980             if (++$i > $#char) {
6981 0 0       0 last;
6982 0         0 }
6983             if ($char[$i] eq '\E') {
6984             last;
6985             }
6986             }
6987             }
6988             elsif ($char[$i] eq '\E') {
6989             }
6990              
6991 0 0       0 # $0 --> $0
6992 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6993             if ($ignorecase) {
6994             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
6995             }
6996 0 0       0 }
6997 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6998             if ($ignorecase) {
6999             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7000             }
7001             }
7002              
7003             # $$ --> $$
7004             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7005             }
7006              
7007             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7008 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7009 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7010 0         0 $char[$i] = e_capture($1);
7011             if ($ignorecase) {
7012             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7013             }
7014 0         0 }
7015 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7016 0         0 $char[$i] = e_capture($1);
7017             if ($ignorecase) {
7018             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7019             }
7020             }
7021              
7022 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7023 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7024 0         0 $char[$i] = e_capture($1.'->'.$2);
7025             if ($ignorecase) {
7026             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7027             }
7028             }
7029              
7030 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7031 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7032 0         0 $char[$i] = e_capture($1.'->'.$2);
7033             if ($ignorecase) {
7034             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7035             }
7036             }
7037              
7038 0         0 # $$foo
7039 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7040 0         0 $char[$i] = e_capture($1);
7041             if ($ignorecase) {
7042             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7043             }
7044             }
7045              
7046 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin10::PREMATCH()
7047 12         34 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7048             if ($ignorecase) {
7049             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::PREMATCH())]}';
7050 0         0 }
7051             else {
7052             $char[$i] = '@{[Elatin10::PREMATCH()]}';
7053             }
7054             }
7055              
7056 12 50       52 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin10::MATCH()
7057 12         31 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7058             if ($ignorecase) {
7059             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::MATCH())]}';
7060 0         0 }
7061             else {
7062             $char[$i] = '@{[Elatin10::MATCH()]}';
7063             }
7064             }
7065              
7066 12 50       52 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin10::POSTMATCH()
7067 9         23 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7068             if ($ignorecase) {
7069             $char[$i] = '@{[Elatin10::ignorecase(Elatin10::POSTMATCH())]}';
7070 0         0 }
7071             else {
7072             $char[$i] = '@{[Elatin10::POSTMATCH()]}';
7073             }
7074             }
7075              
7076 9 0       41 # ${ foo }
7077 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7078             if ($ignorecase) {
7079             $char[$i] = '@{[Elatin10::ignorecase(' . $1 . ')]}';
7080             }
7081             }
7082              
7083 0         0 # ${ ... }
7084 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7085 0         0 $char[$i] = e_capture($1);
7086             if ($ignorecase) {
7087             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7088             }
7089             }
7090              
7091 0         0 # $scalar or @array
7092 3 50       8 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7093 3         11 $char[$i] = e_string($char[$i]);
7094             if ($ignorecase) {
7095             $char[$i] = '@{[Elatin10::ignorecase(' . $char[$i] . ')]}';
7096             }
7097             }
7098              
7099 0 50       0 # quote character before ? + * {
7100             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7101             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7102 1         6 }
7103             else {
7104             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7105             }
7106             }
7107             }
7108 0         0  
7109 74 50       138 # make regexp string
7110 74         167 $modifier =~ tr/i//d;
7111             if ($left_e > $right_e) {
7112 0         0 return join '', 'Elatin10::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7113             }
7114             return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7115             }
7116              
7117             #
7118             # escape regexp of split qr''
7119 74     0 0 705 #
7120 0   0       sub e_split_q {
7121             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7122 0           $modifier ||= '';
7123 0 0          
7124 0           $modifier =~ tr/p//d;
7125 0           if ($modifier =~ /([adlu])/oxms) {
7126 0 0         my $line = 0;
7127 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7128 0           if ($filename ne __FILE__) {
7129             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7130             last;
7131 0           }
7132             }
7133             die qq{Unsupported modifier "$1" used at line $line.\n};
7134 0           }
7135              
7136             $slash = 'div';
7137 0 0          
7138 0           # /b /B modifier
7139             if ($modifier =~ tr/bB//d) {
7140             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7141 0 0         }
7142              
7143             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7144 0            
7145             # split regexp
7146             my @char = $string =~ /\G((?>
7147             [^\\\[] |
7148             [\x00-\xFF] |
7149             \[\^ |
7150             \[\: (?>[a-z]+) \:\] |
7151             \[\:\^ (?>[a-z]+) \:\] |
7152             \\ (?:$q_char) |
7153             (?:$q_char)
7154             ))/oxmsg;
7155 0            
7156 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7157             for (my $i=0; $i <= $#char; $i++) {
7158             if (0) {
7159             }
7160 0            
7161 0           # open character class [...]
7162 0 0         elsif ($char[$i] eq '[') {
7163 0           my $left = $i;
7164             if ($char[$i+1] eq ']') {
7165 0           $i++;
7166 0 0         }
7167 0           while (1) {
7168             if (++$i > $#char) {
7169 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7170 0           }
7171             if ($char[$i] eq ']') {
7172             my $right = $i;
7173 0            
7174             # [...]
7175 0           splice @char, $left, $right-$left+1, Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7176 0            
7177             $i = $left;
7178             last;
7179             }
7180             }
7181             }
7182              
7183 0           # open character class [^...]
7184 0 0         elsif ($char[$i] eq '[^') {
7185 0           my $left = $i;
7186             if ($char[$i+1] eq ']') {
7187 0           $i++;
7188 0 0         }
7189 0           while (1) {
7190             if (++$i > $#char) {
7191 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7192 0           }
7193             if ($char[$i] eq ']') {
7194             my $right = $i;
7195 0            
7196             # [^...]
7197 0           splice @char, $left, $right-$left+1, Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7198 0            
7199             $i = $left;
7200             last;
7201             }
7202             }
7203             }
7204              
7205 0           # rewrite character class or escape character
7206             elsif (my $char = character_class($char[$i],$modifier)) {
7207             $char[$i] = $char;
7208             }
7209              
7210 0           # split(m/^/) --> split(m/^/m)
7211             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7212             $modifier .= 'm';
7213             }
7214              
7215 0 0         # /i modifier
7216 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin10::uc($char[$i]) ne Elatin10::fc($char[$i]))) {
7217             if (CORE::length(Elatin10::fc($char[$i])) == 1) {
7218             $char[$i] = '[' . Elatin10::uc($char[$i]) . Elatin10::fc($char[$i]) . ']';
7219 0           }
7220             else {
7221             $char[$i] = '(?:' . Elatin10::uc($char[$i]) . '|' . Elatin10::fc($char[$i]) . ')';
7222             }
7223             }
7224              
7225 0 0         # quote character before ? + * {
7226             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7227             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7228 0           }
7229             else {
7230             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7231             }
7232             }
7233 0           }
7234 0            
7235             $modifier =~ tr/i//d;
7236             return join '', 'Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7237             }
7238              
7239             #
7240             # instead of Carp::carp
7241 0     0 0   #
7242 0           sub carp {
7243             my($package,$filename,$line) = caller(1);
7244             print STDERR "@_ at $filename line $line.\n";
7245             }
7246              
7247             #
7248             # instead of Carp::croak
7249 0     0 0   #
7250 0           sub croak {
7251 0           my($package,$filename,$line) = caller(1);
7252             print STDERR "@_ at $filename line $line.\n";
7253             die "\n";
7254             }
7255              
7256             #
7257             # instead of Carp::cluck
7258 0     0 0   #
7259 0           sub cluck {
7260 0           my $i = 0;
7261 0           my @cluck = ();
7262 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7263             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7264 0           $i++;
7265 0           }
7266 0           print STDERR CORE::reverse @cluck;
7267             print STDERR "\n";
7268             print STDERR @_;
7269             }
7270              
7271             #
7272             # instead of Carp::confess
7273 0     0 0   #
7274 0           sub confess {
7275 0           my $i = 0;
7276 0           my @confess = ();
7277 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7278             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7279 0           $i++;
7280 0           }
7281 0           print STDERR CORE::reverse @confess;
7282 0           print STDERR "\n";
7283             print STDERR @_;
7284             die "\n";
7285             }
7286              
7287             1;
7288              
7289             __END__