File Coverage

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