File Coverage

blib/lib/Elatin8.pm
Criterion Covered Total %
statement 905 3196 28.3
branch 968 2742 35.3
condition 98 355 27.6
subroutine 52 110 47.2
pod 7 74 9.4
total 2030 6477 31.3


line stmt bran cond sub pod time code
1             package Elatin8;
2 204     204   2315 use strict;
  204         336  
  204         6770  
3             ######################################################################
4             #
5             # Elatin8 - Run-time routines for Latin8.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin8/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   5618 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         613  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 204     204   1139 use vars qw($VERSION);
  204         457  
  204         35447  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1479 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         375 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         38336 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44              
45             # instead of utf8.pm
46 204     204   23905 CORE::eval q{
  204     204   2335  
  204     56   425  
  204         25189  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 204 50       149265 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     0 0 0 my($name) = @_;
78              
79 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
80 0         0 return $name;
81             }
82             elsif (Elatin8::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Elatin8::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 0         0 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 0   0 0 0 if (defined $_[1]) {
117 204     204   1464 no strict qw(refs);
  204         411  
  204         24428  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   2495 no strict qw(refs);
  204     0   1155  
  204         49706  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x00-\xFF]};
153 204     204   1542 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         407  
  204         19999  
154 204     204   1554 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         392  
  204         520753  
155              
156             #
157             # Latin-8 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Latin-8 case conversion
163             #
164             my %lc = ();
165             @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)} =
166             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
167             my %uc = ();
168             @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)} =
169             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
170             my %fc = ();
171             @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)} =
172             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              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Elatin8 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xA1" => "\xA2", # LATIN LETTER B WITH DOT ABOVE
185             "\xA4" => "\xA5", # LATIN LETTER C WITH DOT ABOVE
186             "\xA6" => "\xAB", # LATIN LETTER D WITH DOT ABOVE
187             "\xA8" => "\xB8", # LATIN LETTER W WITH GRAVE
188             "\xAA" => "\xBA", # LATIN LETTER W WITH ACUTE
189             "\xAC" => "\xBC", # LATIN LETTER Y WITH GRAVE
190             "\xAF" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
191             "\xB0" => "\xB1", # LATIN LETTER F WITH DOT ABOVE
192             "\xB2" => "\xB3", # LATIN LETTER G WITH DOT ABOVE
193             "\xB4" => "\xB5", # LATIN LETTER M WITH DOT ABOVE
194             "\xB7" => "\xB9", # LATIN LETTER P WITH DOT ABOVE
195             "\xBB" => "\xBF", # LATIN LETTER S WITH DOT ABOVE
196             "\xBD" => "\xBE", # LATIN LETTER W WITH DIAERESIS
197             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
198             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
199             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
200             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
201             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
202             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
203             "\xC6" => "\xE6", # LATIN LETTER AE
204             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
205             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
206             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
207             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
208             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
209             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
210             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
211             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
212             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
213             "\xD0" => "\xF0", # LATIN LETTER W WITH CIRCUMFLEX
214             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
215             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
216             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
217             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
218             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
219             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
220             "\xD7" => "\xF7", # LATIN LETTER T WITH DOT ABOVE
221             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
222             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
223             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
224             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
225             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
226             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
227             "\xDE" => "\xFE", # LATIN LETTER Y WITH CIRCUMFLEX
228             );
229              
230             %uc = (%uc,
231             "\xA2" => "\xA1", # LATIN LETTER B WITH DOT ABOVE
232             "\xA5" => "\xA4", # LATIN LETTER C WITH DOT ABOVE
233             "\xAB" => "\xA6", # LATIN LETTER D WITH DOT ABOVE
234             "\xB1" => "\xB0", # LATIN LETTER F WITH DOT ABOVE
235             "\xB3" => "\xB2", # LATIN LETTER G WITH DOT ABOVE
236             "\xB5" => "\xB4", # LATIN LETTER M WITH DOT ABOVE
237             "\xB8" => "\xA8", # LATIN LETTER W WITH GRAVE
238             "\xB9" => "\xB7", # LATIN LETTER P WITH DOT ABOVE
239             "\xBA" => "\xAA", # LATIN LETTER W WITH ACUTE
240             "\xBC" => "\xAC", # LATIN LETTER Y WITH GRAVE
241             "\xBE" => "\xBD", # LATIN LETTER W WITH DIAERESIS
242             "\xBF" => "\xBB", # LATIN LETTER S WITH DOT ABOVE
243             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
244             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
245             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
246             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
247             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
248             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
249             "\xE6" => "\xC6", # LATIN LETTER AE
250             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
251             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
252             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
253             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
254             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
255             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
256             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
257             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
258             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
259             "\xF0" => "\xD0", # LATIN LETTER W WITH CIRCUMFLEX
260             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
261             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
262             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
263             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
264             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
265             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
266             "\xF7" => "\xD7", # LATIN LETTER T WITH DOT ABOVE
267             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
268             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
269             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
270             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
271             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
272             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
273             "\xFE" => "\xDE", # LATIN LETTER Y WITH CIRCUMFLEX
274             "\xFF" => "\xAF", # LATIN LETTER Y WITH DIAERESIS
275             );
276              
277             %fc = (%fc,
278             "\xA1" => "\xA2", # LATIN CAPITAL LETTER B WITH DOT ABOVE --> LATIN SMALL LETTER B WITH DOT ABOVE
279             "\xA4" => "\xA5", # LATIN CAPITAL LETTER C WITH DOT ABOVE --> LATIN SMALL LETTER C WITH DOT ABOVE
280             "\xA6" => "\xAB", # LATIN CAPITAL LETTER D WITH DOT ABOVE --> LATIN SMALL LETTER D WITH DOT ABOVE
281             "\xA8" => "\xB8", # LATIN CAPITAL LETTER W WITH GRAVE --> LATIN SMALL LETTER W WITH GRAVE
282             "\xAA" => "\xBA", # LATIN CAPITAL LETTER W WITH ACUTE --> LATIN SMALL LETTER W WITH ACUTE
283             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Y WITH GRAVE --> LATIN SMALL LETTER Y WITH GRAVE
284             "\xAF" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
285             "\xB0" => "\xB1", # LATIN CAPITAL LETTER F WITH DOT ABOVE --> LATIN SMALL LETTER F WITH DOT ABOVE
286             "\xB2" => "\xB3", # LATIN CAPITAL LETTER G WITH DOT ABOVE --> LATIN SMALL LETTER G WITH DOT ABOVE
287             "\xB4" => "\xB5", # LATIN CAPITAL LETTER M WITH DOT ABOVE --> LATIN SMALL LETTER M WITH DOT ABOVE
288             "\xB7" => "\xB9", # LATIN CAPITAL LETTER P WITH DOT ABOVE --> LATIN SMALL LETTER P WITH DOT ABOVE
289             "\xBB" => "\xBF", # LATIN CAPITAL LETTER S WITH DOT ABOVE --> LATIN SMALL LETTER S WITH DOT ABOVE
290             "\xBD" => "\xBE", # LATIN CAPITAL LETTER W WITH DIAERESIS --> LATIN SMALL LETTER W WITH DIAERESIS
291             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
292             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
293             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
294             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
295             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
296             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
297             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
298             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
299             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
300             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
301             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
302             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
303             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
304             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
305             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
306             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
307             "\xD0" => "\xF0", # LATIN CAPITAL LETTER W WITH CIRCUMFLEX --> LATIN SMALL LETTER W WITH CIRCUMFLEX
308             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
309             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
310             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
311             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
312             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
313             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
314             "\xD7" => "\xF7", # LATIN CAPITAL LETTER T WITH DOT ABOVE --> LATIN SMALL LETTER T WITH DOT ABOVE
315             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
316             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
317             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
318             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
319             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
320             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
321             "\xDE" => "\xFE", # LATIN CAPITAL LETTER Y WITH CIRCUMFLEX --> LATIN SMALL LETTER Y WITH CIRCUMFLEX
322             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
323             );
324             }
325              
326             else {
327             croak "Don't know my package name '@{[__PACKAGE__]}'";
328             }
329              
330             #
331             # @ARGV wildcard globbing
332             #
333             sub import {
334              
335 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
336 0         0 my @argv = ();
337 0         0 for (@ARGV) {
338              
339             # has space
340 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
341 0 0       0 if (my @glob = Elatin8::glob(qq{"$_"})) {
342 0         0 push @argv, @glob;
343             }
344             else {
345 0         0 push @argv, $_;
346             }
347             }
348              
349             # has wildcard metachar
350             elsif (/\A (?:$q_char)*? [*?] /oxms) {
351 0 0       0 if (my @glob = Elatin8::glob($_)) {
352 0         0 push @argv, @glob;
353             }
354             else {
355 0         0 push @argv, $_;
356             }
357             }
358              
359             # no wildcard globbing
360             else {
361 0         0 push @argv, $_;
362             }
363             }
364 0         0 @ARGV = @argv;
365             }
366              
367 0         0 *Char::ord = \&Latin8::ord;
368 0         0 *Char::ord_ = \&Latin8::ord_;
369 0         0 *Char::reverse = \&Latin8::reverse;
370 0         0 *Char::getc = \&Latin8::getc;
371 0         0 *Char::length = \&Latin8::length;
372 0         0 *Char::substr = \&Latin8::substr;
373 0         0 *Char::index = \&Latin8::index;
374 0         0 *Char::rindex = \&Latin8::rindex;
375 0         0 *Char::eval = \&Latin8::eval;
376 0         0 *Char::escape = \&Latin8::escape;
377 0         0 *Char::escape_token = \&Latin8::escape_token;
378 0         0 *Char::escape_script = \&Latin8::escape_script;
379             }
380              
381             # P.230 Care with Prototypes
382             # in Chapter 6: Subroutines
383             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
384             #
385             # If you aren't careful, you can get yourself into trouble with prototypes.
386             # But if you are careful, you can do a lot of neat things with them. This is
387             # all very powerful, of course, and should only be used in moderation to make
388             # the world a better place.
389              
390             # P.332 Care with Prototypes
391             # in Chapter 7: Subroutines
392             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
393             #
394             # If you aren't careful, you can get yourself into trouble with prototypes.
395             # But if you are careful, you can do a lot of neat things with them. This is
396             # all very powerful, of course, and should only be used in moderation to make
397             # the world a better place.
398              
399             #
400             # Prototypes of subroutines
401             #
402       0     sub unimport {}
403             sub Elatin8::split(;$$$);
404             sub Elatin8::tr($$$$;$);
405             sub Elatin8::chop(@);
406             sub Elatin8::index($$;$);
407             sub Elatin8::rindex($$;$);
408             sub Elatin8::lcfirst(@);
409             sub Elatin8::lcfirst_();
410             sub Elatin8::lc(@);
411             sub Elatin8::lc_();
412             sub Elatin8::ucfirst(@);
413             sub Elatin8::ucfirst_();
414             sub Elatin8::uc(@);
415             sub Elatin8::uc_();
416             sub Elatin8::fc(@);
417             sub Elatin8::fc_();
418             sub Elatin8::ignorecase;
419             sub Elatin8::classic_character_class;
420             sub Elatin8::capture;
421             sub Elatin8::chr(;$);
422             sub Elatin8::chr_();
423             sub Elatin8::glob($);
424             sub Elatin8::glob_();
425              
426             sub Latin8::ord(;$);
427             sub Latin8::ord_();
428             sub Latin8::reverse(@);
429             sub Latin8::getc(;*@);
430             sub Latin8::length(;$);
431             sub Latin8::substr($$;$$);
432             sub Latin8::index($$;$);
433             sub Latin8::rindex($$;$);
434             sub Latin8::escape(;$);
435              
436             #
437             # Regexp work
438             #
439 204         17373 use vars qw(
440             $re_a
441             $re_t
442             $re_n
443             $re_r
444 204     204   1732 );
  204         404  
445              
446             #
447             # Character class
448             #
449 204         2302764 use vars qw(
450             $dot
451             $dot_s
452             $eD
453             $eS
454             $eW
455             $eH
456             $eV
457             $eR
458             $eN
459             $not_alnum
460             $not_alpha
461             $not_ascii
462             $not_blank
463             $not_cntrl
464             $not_digit
465             $not_graph
466             $not_lower
467             $not_lower_i
468             $not_print
469             $not_punct
470             $not_space
471             $not_upper
472             $not_upper_i
473             $not_word
474             $not_xdigit
475             $eb
476             $eB
477 204     204   1874 );
  204         384  
478              
479             ${Elatin8::dot} = qr{(?>[^\x0A])};
480             ${Elatin8::dot_s} = qr{(?>[\x00-\xFF])};
481             ${Elatin8::eD} = qr{(?>[^0-9])};
482              
483             # Vertical tabs are now whitespace
484             # \s in a regex now matches a vertical tab in all circumstances.
485             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
486             # ${Elatin8::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
487             # ${Elatin8::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
488             ${Elatin8::eS} = qr{(?>[^\s])};
489              
490             ${Elatin8::eW} = qr{(?>[^0-9A-Z_a-z])};
491             ${Elatin8::eH} = qr{(?>[^\x09\x20])};
492             ${Elatin8::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
493             ${Elatin8::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
494             ${Elatin8::eN} = qr{(?>[^\x0A])};
495             ${Elatin8::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
496             ${Elatin8::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
497             ${Elatin8::not_ascii} = qr{(?>[^\x00-\x7F])};
498             ${Elatin8::not_blank} = qr{(?>[^\x09\x20])};
499             ${Elatin8::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
500             ${Elatin8::not_digit} = qr{(?>[^\x30-\x39])};
501             ${Elatin8::not_graph} = qr{(?>[^\x21-\x7F])};
502             ${Elatin8::not_lower} = qr{(?>[^\x61-\x7A])};
503             ${Elatin8::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
504             # ${Elatin8::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
505             ${Elatin8::not_print} = qr{(?>[^\x20-\x7F])};
506             ${Elatin8::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
507             ${Elatin8::not_space} = qr{(?>[^\s\x0B])};
508             ${Elatin8::not_upper} = qr{(?>[^\x41-\x5A])};
509             ${Elatin8::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
510             # ${Elatin8::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
511             ${Elatin8::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
512             ${Elatin8::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
513             ${Elatin8::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))};
514             ${Elatin8::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]))};
515              
516             # avoid: Name "Elatin8::foo" used only once: possible typo at here.
517             ${Elatin8::dot} = ${Elatin8::dot};
518             ${Elatin8::dot_s} = ${Elatin8::dot_s};
519             ${Elatin8::eD} = ${Elatin8::eD};
520             ${Elatin8::eS} = ${Elatin8::eS};
521             ${Elatin8::eW} = ${Elatin8::eW};
522             ${Elatin8::eH} = ${Elatin8::eH};
523             ${Elatin8::eV} = ${Elatin8::eV};
524             ${Elatin8::eR} = ${Elatin8::eR};
525             ${Elatin8::eN} = ${Elatin8::eN};
526             ${Elatin8::not_alnum} = ${Elatin8::not_alnum};
527             ${Elatin8::not_alpha} = ${Elatin8::not_alpha};
528             ${Elatin8::not_ascii} = ${Elatin8::not_ascii};
529             ${Elatin8::not_blank} = ${Elatin8::not_blank};
530             ${Elatin8::not_cntrl} = ${Elatin8::not_cntrl};
531             ${Elatin8::not_digit} = ${Elatin8::not_digit};
532             ${Elatin8::not_graph} = ${Elatin8::not_graph};
533             ${Elatin8::not_lower} = ${Elatin8::not_lower};
534             ${Elatin8::not_lower_i} = ${Elatin8::not_lower_i};
535             ${Elatin8::not_print} = ${Elatin8::not_print};
536             ${Elatin8::not_punct} = ${Elatin8::not_punct};
537             ${Elatin8::not_space} = ${Elatin8::not_space};
538             ${Elatin8::not_upper} = ${Elatin8::not_upper};
539             ${Elatin8::not_upper_i} = ${Elatin8::not_upper_i};
540             ${Elatin8::not_word} = ${Elatin8::not_word};
541             ${Elatin8::not_xdigit} = ${Elatin8::not_xdigit};
542             ${Elatin8::eb} = ${Elatin8::eb};
543             ${Elatin8::eB} = ${Elatin8::eB};
544              
545             #
546             # Latin-8 split
547             #
548             sub Elatin8::split(;$$$) {
549              
550             # P.794 29.2.161. split
551             # in Chapter 29: Functions
552             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
553              
554             # P.951 split
555             # in Chapter 27: Functions
556             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
557              
558 0     0 0 0 my $pattern = $_[0];
559 0         0 my $string = $_[1];
560 0         0 my $limit = $_[2];
561              
562             # if $pattern is also omitted or is the literal space, " "
563 0 0       0 if (not defined $pattern) {
564 0         0 $pattern = ' ';
565             }
566              
567             # if $string is omitted, the function splits the $_ string
568 0 0       0 if (not defined $string) {
569 0 0       0 if (defined $_) {
570 0         0 $string = $_;
571             }
572             else {
573 0         0 $string = '';
574             }
575             }
576              
577 0         0 my @split = ();
578              
579             # when string is empty
580 0 0       0 if ($string eq '') {
    0          
581              
582             # resulting list value in list context
583 0 0       0 if (wantarray) {
584 0         0 return @split;
585             }
586              
587             # count of substrings in scalar context
588             else {
589 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
590 0         0 @_ = @split;
591 0         0 return scalar @_;
592             }
593             }
594              
595             # split's first argument is more consistently interpreted
596             #
597             # After some changes earlier in v5.17, split's behavior has been simplified:
598             # if the PATTERN argument evaluates to a string containing one space, it is
599             # treated the way that a literal string containing one space once was.
600             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
601              
602             # if $pattern is also omitted or is the literal space, " ", the function splits
603             # on whitespace, /\s+/, after skipping any leading whitespace
604             # (and so on)
605              
606             elsif ($pattern eq ' ') {
607 0 0       0 if (not defined $limit) {
608 0         0 return CORE::split(' ', $string);
609             }
610             else {
611 0         0 return CORE::split(' ', $string, $limit);
612             }
613             }
614              
615             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
616 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
617              
618             # a pattern capable of matching either the null string or something longer than the
619             # null string will split the value of $string into separate characters wherever it
620             # matches the null string between characters
621             # (and so on)
622              
623 0 0       0 if ('' =~ / \A $pattern \z /xms) {
624 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
625 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
626              
627             # P.1024 Appendix W.10 Multibyte Processing
628             # of ISBN 1-56592-224-7 CJKV Information Processing
629             # (and so on)
630              
631             # the //m modifier is assumed when you split on the pattern /^/
632             # (and so on)
633              
634             # V
635 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
636              
637             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
638             # is included in the resulting list, interspersed with the fields that are ordinarily returned
639             # (and so on)
640              
641 0         0 local $@;
642 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
643 0         0 push @split, CORE::eval('$' . $digit);
644             }
645             }
646             }
647              
648             else {
649 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
650              
651             # V
652 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
653 0         0 local $@;
654 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
655 0         0 push @split, CORE::eval('$' . $digit);
656             }
657             }
658             }
659             }
660              
661             elsif ($limit > 0) {
662 0 0       0 if ('' =~ / \A $pattern \z /xms) {
663 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
664 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
665              
666             # V
667 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
668 0         0 local $@;
669 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
670 0         0 push @split, CORE::eval('$' . $digit);
671             }
672             }
673             }
674             }
675             else {
676 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
677 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
678              
679             # V
680 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
681 0         0 local $@;
682 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
683 0         0 push @split, CORE::eval('$' . $digit);
684             }
685             }
686             }
687             }
688             }
689              
690 0 0       0 if (CORE::length($string) > 0) {
691 0         0 push @split, $string;
692             }
693              
694             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
695 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
696 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
697 0         0 pop @split;
698             }
699             }
700              
701             # resulting list value in list context
702 0 0       0 if (wantarray) {
703 0         0 return @split;
704             }
705              
706             # count of substrings in scalar context
707             else {
708 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
709 0         0 @_ = @split;
710 0         0 return scalar @_;
711             }
712             }
713              
714             #
715             # get last subexpression offsets
716             #
717             sub _last_subexpression_offsets {
718 0     0   0 my $pattern = $_[0];
719              
720             # remove comment
721 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
722              
723 0         0 my $modifier = '';
724 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
725 0         0 $modifier = $1;
726 0         0 $modifier =~ s/-[A-Za-z]*//;
727             }
728              
729             # with /x modifier
730 0         0 my @char = ();
731 0 0       0 if ($modifier =~ /x/oxms) {
732 0         0 @char = $pattern =~ /\G((?>
733             [^\\\#\[\(] |
734             \\ $q_char |
735             \# (?>[^\n]*) $ |
736             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
737             \(\? |
738             $q_char
739             ))/oxmsg;
740             }
741              
742             # without /x modifier
743             else {
744 0         0 @char = $pattern =~ /\G((?>
745             [^\\\[\(] |
746             \\ $q_char |
747             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
748             \(\? |
749             $q_char
750             ))/oxmsg;
751             }
752              
753 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
754             }
755              
756             #
757             # Latin-8 transliteration (tr///)
758             #
759             sub Elatin8::tr($$$$;$) {
760              
761 0     0 0 0 my $bind_operator = $_[1];
762 0         0 my $searchlist = $_[2];
763 0         0 my $replacementlist = $_[3];
764 0   0     0 my $modifier = $_[4] || '';
765              
766 0 0       0 if ($modifier =~ /r/oxms) {
767 0 0       0 if ($bind_operator =~ / !~ /oxms) {
768 0         0 croak "Using !~ with tr///r doesn't make sense";
769             }
770             }
771              
772 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
773 0         0 my @searchlist = _charlist_tr($searchlist);
774 0         0 my @replacementlist = _charlist_tr($replacementlist);
775              
776 0         0 my %tr = ();
777 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
778 0 0       0 if (not exists $tr{$searchlist[$i]}) {
779 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
780 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
781             }
782             elsif ($modifier =~ /d/oxms) {
783 0         0 $tr{$searchlist[$i]} = '';
784             }
785             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
786 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
787             }
788             else {
789 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
790             }
791             }
792             }
793              
794 0         0 my $tr = 0;
795 0         0 my $replaced = '';
796 0 0       0 if ($modifier =~ /c/oxms) {
797 0         0 while (defined(my $char = shift @char)) {
798 0 0       0 if (not exists $tr{$char}) {
799 0 0       0 if (defined $replacementlist[0]) {
800 0         0 $replaced .= $replacementlist[0];
801             }
802 0         0 $tr++;
803 0 0       0 if ($modifier =~ /s/oxms) {
804 0   0     0 while (@char and (not exists $tr{$char[0]})) {
805 0         0 shift @char;
806 0         0 $tr++;
807             }
808             }
809             }
810             else {
811 0         0 $replaced .= $char;
812             }
813             }
814             }
815             else {
816 0         0 while (defined(my $char = shift @char)) {
817 0 0       0 if (exists $tr{$char}) {
818 0         0 $replaced .= $tr{$char};
819 0         0 $tr++;
820 0 0       0 if ($modifier =~ /s/oxms) {
821 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
822 0         0 shift @char;
823 0         0 $tr++;
824             }
825             }
826             }
827             else {
828 0         0 $replaced .= $char;
829             }
830             }
831             }
832              
833 0 0       0 if ($modifier =~ /r/oxms) {
834 0         0 return $replaced;
835             }
836             else {
837 0         0 $_[0] = $replaced;
838 0 0       0 if ($bind_operator =~ / !~ /oxms) {
839 0         0 return not $tr;
840             }
841             else {
842 0         0 return $tr;
843             }
844             }
845             }
846              
847             #
848             # Latin-8 chop
849             #
850             sub Elatin8::chop(@) {
851              
852 0     0 0 0 my $chop;
853 0 0       0 if (@_ == 0) {
854 0         0 my @char = /\G (?>$q_char) /oxmsg;
855 0         0 $chop = pop @char;
856 0         0 $_ = join '', @char;
857             }
858             else {
859 0         0 for (@_) {
860 0         0 my @char = /\G (?>$q_char) /oxmsg;
861 0         0 $chop = pop @char;
862 0         0 $_ = join '', @char;
863             }
864             }
865 0         0 return $chop;
866             }
867              
868             #
869             # Latin-8 index by octet
870             #
871             sub Elatin8::index($$;$) {
872              
873 0     0 1 0 my($str,$substr,$position) = @_;
874 0   0     0 $position ||= 0;
875 0         0 my $pos = 0;
876              
877 0         0 while ($pos < CORE::length($str)) {
878 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
879 0 0       0 if ($pos >= $position) {
880 0         0 return $pos;
881             }
882             }
883 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
884 0         0 $pos += CORE::length($1);
885             }
886             else {
887 0         0 $pos += 1;
888             }
889             }
890 0         0 return -1;
891             }
892              
893             #
894             # Latin-8 reverse index
895             #
896             sub Elatin8::rindex($$;$) {
897              
898 0     0 0 0 my($str,$substr,$position) = @_;
899 0   0     0 $position ||= CORE::length($str) - 1;
900 0         0 my $pos = 0;
901 0         0 my $rindex = -1;
902              
903 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
904 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
905 0         0 $rindex = $pos;
906             }
907 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
908 0         0 $pos += CORE::length($1);
909             }
910             else {
911 0         0 $pos += 1;
912             }
913             }
914 0         0 return $rindex;
915             }
916              
917             #
918             # Latin-8 lower case first with parameter
919             #
920             sub Elatin8::lcfirst(@) {
921 0 0   0 0 0 if (@_) {
922 0         0 my $s = shift @_;
923 0 0 0     0 if (@_ and wantarray) {
924 0         0 return Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
925             }
926             else {
927 0         0 return Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
928             }
929             }
930             else {
931 0         0 return Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
932             }
933             }
934              
935             #
936             # Latin-8 lower case first without parameter
937             #
938             sub Elatin8::lcfirst_() {
939 0     0 0 0 return Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
940             }
941              
942             #
943             # Latin-8 lower case with parameter
944             #
945             sub Elatin8::lc(@) {
946 0 0   0 0 0 if (@_) {
947 0         0 my $s = shift @_;
948 0 0 0     0 if (@_ and wantarray) {
949 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
950             }
951             else {
952 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
953             }
954             }
955             else {
956 0         0 return Elatin8::lc_();
957             }
958             }
959              
960             #
961             # Latin-8 lower case without parameter
962             #
963             sub Elatin8::lc_() {
964 0     0 0 0 my $s = $_;
965 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
966             }
967              
968             #
969             # Latin-8 upper case first with parameter
970             #
971             sub Elatin8::ucfirst(@) {
972 0 0   0 0 0 if (@_) {
973 0         0 my $s = shift @_;
974 0 0 0     0 if (@_ and wantarray) {
975 0         0 return Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
976             }
977             else {
978 0         0 return Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
979             }
980             }
981             else {
982 0         0 return Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
983             }
984             }
985              
986             #
987             # Latin-8 upper case first without parameter
988             #
989             sub Elatin8::ucfirst_() {
990 0     0 0 0 return Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
991             }
992              
993             #
994             # Latin-8 upper case with parameter
995             #
996             sub Elatin8::uc(@) {
997 0 50   174 0 0 if (@_) {
998 174         338 my $s = shift @_;
999 174 50 33     351 if (@_ and wantarray) {
1000 174 0       317 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1001             }
1002             else {
1003 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         603  
1004             }
1005             }
1006             else {
1007 174         996 return Elatin8::uc_();
1008             }
1009             }
1010              
1011             #
1012             # Latin-8 upper case without parameter
1013             #
1014             sub Elatin8::uc_() {
1015 0     0 0 0 my $s = $_;
1016 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1017             }
1018              
1019             #
1020             # Latin-8 fold case with parameter
1021             #
1022             sub Elatin8::fc(@) {
1023 0 50   197 0 0 if (@_) {
1024 197         296 my $s = shift @_;
1025 197 50 33     240 if (@_ and wantarray) {
1026 197 0       411 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1027             }
1028             else {
1029 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         639  
1030             }
1031             }
1032             else {
1033 197         1077 return Elatin8::fc_();
1034             }
1035             }
1036              
1037             #
1038             # Latin-8 fold case without parameter
1039             #
1040             sub Elatin8::fc_() {
1041 0     0 0 0 my $s = $_;
1042 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1043             }
1044              
1045             #
1046             # Latin-8 regexp capture
1047             #
1048             {
1049             sub Elatin8::capture {
1050 0     0 1 0 return $_[0];
1051             }
1052             }
1053              
1054             #
1055             # Latin-8 regexp ignore case modifier
1056             #
1057             sub Elatin8::ignorecase {
1058              
1059 0     0 0 0 my @string = @_;
1060 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1061              
1062             # ignore case of $scalar or @array
1063 0         0 for my $string (@string) {
1064              
1065             # split regexp
1066 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1067              
1068             # unescape character
1069 0         0 for (my $i=0; $i <= $#char; $i++) {
1070 0 0       0 next if not defined $char[$i];
1071              
1072             # open character class [...]
1073 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1074 0         0 my $left = $i;
1075              
1076             # [] make die "unmatched [] in regexp ...\n"
1077              
1078 0 0       0 if ($char[$i+1] eq ']') {
1079 0         0 $i++;
1080             }
1081              
1082 0         0 while (1) {
1083 0 0       0 if (++$i > $#char) {
1084 0         0 croak "Unmatched [] in regexp";
1085             }
1086 0 0       0 if ($char[$i] eq ']') {
1087 0         0 my $right = $i;
1088 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1089              
1090             # escape character
1091 0         0 for my $char (@charlist) {
1092 0 0       0 if (0) {
1093             }
1094              
1095 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1096 0         0 $char = '\\' . $char;
1097             }
1098             }
1099              
1100             # [...]
1101 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1102              
1103 0         0 $i = $left;
1104 0         0 last;
1105             }
1106             }
1107             }
1108              
1109             # open character class [^...]
1110             elsif ($char[$i] eq '[^') {
1111 0         0 my $left = $i;
1112              
1113             # [^] make die "unmatched [] in regexp ...\n"
1114              
1115 0 0       0 if ($char[$i+1] eq ']') {
1116 0         0 $i++;
1117             }
1118              
1119 0         0 while (1) {
1120 0 0       0 if (++$i > $#char) {
1121 0         0 croak "Unmatched [] in regexp";
1122             }
1123 0 0       0 if ($char[$i] eq ']') {
1124 0         0 my $right = $i;
1125 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1126              
1127             # escape character
1128 0         0 for my $char (@charlist) {
1129 0 0       0 if (0) {
1130             }
1131              
1132 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1133 0         0 $char = '\\' . $char;
1134             }
1135             }
1136              
1137             # [^...]
1138 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1139              
1140 0         0 $i = $left;
1141 0         0 last;
1142             }
1143             }
1144             }
1145              
1146             # rewrite classic character class or escape character
1147             elsif (my $char = classic_character_class($char[$i])) {
1148 0         0 $char[$i] = $char;
1149             }
1150              
1151             # with /i modifier
1152             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1153 0         0 my $uc = Elatin8::uc($char[$i]);
1154 0         0 my $fc = Elatin8::fc($char[$i]);
1155 0 0       0 if ($uc ne $fc) {
1156 0 0       0 if (CORE::length($fc) == 1) {
1157 0         0 $char[$i] = '[' . $uc . $fc . ']';
1158             }
1159             else {
1160 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1161             }
1162             }
1163             }
1164             }
1165              
1166             # characterize
1167 0         0 for (my $i=0; $i <= $#char; $i++) {
1168 0 0       0 next if not defined $char[$i];
1169              
1170 0 0       0 if (0) {
1171             }
1172              
1173             # quote character before ? + * {
1174 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1175 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1176 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1177             }
1178             }
1179             }
1180              
1181 0         0 $string = join '', @char;
1182             }
1183              
1184             # make regexp string
1185 0         0 return @string;
1186             }
1187              
1188             #
1189             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1190             #
1191             sub Elatin8::classic_character_class {
1192 0     1867 0 0 my($char) = @_;
1193              
1194             return {
1195             '\D' => '${Elatin8::eD}',
1196             '\S' => '${Elatin8::eS}',
1197             '\W' => '${Elatin8::eW}',
1198             '\d' => '[0-9]',
1199              
1200             # Before Perl 5.6, \s only matched the five whitespace characters
1201             # tab, newline, form-feed, carriage return, and the space character
1202             # itself, which, taken together, is the character class [\t\n\f\r ].
1203              
1204             # Vertical tabs are now whitespace
1205             # \s in a regex now matches a vertical tab in all circumstances.
1206             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1207             # \t \n \v \f \r space
1208             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1209             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1210             '\s' => '\s',
1211              
1212             '\w' => '[0-9A-Z_a-z]',
1213             '\C' => '[\x00-\xFF]',
1214             '\X' => 'X',
1215              
1216             # \h \v \H \V
1217              
1218             # P.114 Character Class Shortcuts
1219             # in Chapter 7: In the World of Regular Expressions
1220             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1221              
1222             # P.357 13.2.3 Whitespace
1223             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1224             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1225             #
1226             # 0x00009 CHARACTER TABULATION h s
1227             # 0x0000a LINE FEED (LF) vs
1228             # 0x0000b LINE TABULATION v
1229             # 0x0000c FORM FEED (FF) vs
1230             # 0x0000d CARRIAGE RETURN (CR) vs
1231             # 0x00020 SPACE h s
1232              
1233             # P.196 Table 5-9. Alphanumeric regex metasymbols
1234             # in Chapter 5. Pattern Matching
1235             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1236              
1237             # (and so on)
1238              
1239             '\H' => '${Elatin8::eH}',
1240             '\V' => '${Elatin8::eV}',
1241             '\h' => '[\x09\x20]',
1242             '\v' => '[\x0A\x0B\x0C\x0D]',
1243             '\R' => '${Elatin8::eR}',
1244              
1245             # \N
1246             #
1247             # http://perldoc.perl.org/perlre.html
1248             # Character Classes and other Special Escapes
1249             # Any character but \n (experimental). Not affected by /s modifier
1250              
1251             '\N' => '${Elatin8::eN}',
1252              
1253             # \b \B
1254              
1255             # P.180 Boundaries: The \b and \B Assertions
1256             # in Chapter 5: Pattern Matching
1257             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1258              
1259             # P.219 Boundaries: The \b and \B Assertions
1260             # in Chapter 5: Pattern Matching
1261             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1262              
1263             # \b really means (?:(?<=\w)(?!\w)|(?
1264             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1265             '\b' => '${Elatin8::eb}',
1266              
1267             # \B really means (?:(?<=\w)(?=\w)|(?
1268             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1269             '\B' => '${Elatin8::eB}',
1270              
1271 1867   100     2623 }->{$char} || '';
1272             }
1273              
1274             #
1275             # prepare Latin-8 characters per length
1276             #
1277              
1278             # 1 octet characters
1279             my @chars1 = ();
1280             sub chars1 {
1281 1867 0   0 0 102092 if (@chars1) {
1282 0         0 return @chars1;
1283             }
1284 0 0       0 if (exists $range_tr{1}) {
1285 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1286 0         0 while (my @range = splice(@ranges,0,1)) {
1287 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1288 0         0 push @chars1, pack 'C', $oct0;
1289             }
1290             }
1291             }
1292 0         0 return @chars1;
1293             }
1294              
1295             # 2 octets characters
1296             my @chars2 = ();
1297             sub chars2 {
1298 0 0   0 0 0 if (@chars2) {
1299 0         0 return @chars2;
1300             }
1301 0 0       0 if (exists $range_tr{2}) {
1302 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1303 0         0 while (my @range = splice(@ranges,0,2)) {
1304 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1305 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1306 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1307             }
1308             }
1309             }
1310             }
1311 0         0 return @chars2;
1312             }
1313              
1314             # 3 octets characters
1315             my @chars3 = ();
1316             sub chars3 {
1317 0 0   0 0 0 if (@chars3) {
1318 0         0 return @chars3;
1319             }
1320 0 0       0 if (exists $range_tr{3}) {
1321 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1322 0         0 while (my @range = splice(@ranges,0,3)) {
1323 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1324 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1325 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1326 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1327             }
1328             }
1329             }
1330             }
1331             }
1332 0         0 return @chars3;
1333             }
1334              
1335             # 4 octets characters
1336             my @chars4 = ();
1337             sub chars4 {
1338 0 0   0 0 0 if (@chars4) {
1339 0         0 return @chars4;
1340             }
1341 0 0       0 if (exists $range_tr{4}) {
1342 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1343 0         0 while (my @range = splice(@ranges,0,4)) {
1344 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1345 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1346 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1347 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1348 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1349             }
1350             }
1351             }
1352             }
1353             }
1354             }
1355 0         0 return @chars4;
1356             }
1357              
1358             #
1359             # Latin-8 open character list for tr
1360             #
1361             sub _charlist_tr {
1362              
1363 0     0   0 local $_ = shift @_;
1364              
1365             # unescape character
1366 0         0 my @char = ();
1367 0         0 while (not /\G \z/oxmsgc) {
1368 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1369 0         0 push @char, '\-';
1370             }
1371             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1372 0         0 push @char, CORE::chr(oct $1);
1373             }
1374             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1375 0         0 push @char, CORE::chr(hex $1);
1376             }
1377             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1378 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1379             }
1380             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1381             push @char, {
1382             '\0' => "\0",
1383             '\n' => "\n",
1384             '\r' => "\r",
1385             '\t' => "\t",
1386             '\f' => "\f",
1387             '\b' => "\x08", # \b means backspace in character class
1388             '\a' => "\a",
1389             '\e' => "\e",
1390 0         0 }->{$1};
1391             }
1392             elsif (/\G \\ ($q_char) /oxmsgc) {
1393 0         0 push @char, $1;
1394             }
1395             elsif (/\G ($q_char) /oxmsgc) {
1396 0         0 push @char, $1;
1397             }
1398             }
1399              
1400             # join separated multiple-octet
1401 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1402              
1403             # unescape '-'
1404 0         0 my @i = ();
1405 0         0 for my $i (0 .. $#char) {
1406 0 0       0 if ($char[$i] eq '\-') {
    0          
1407 0         0 $char[$i] = '-';
1408             }
1409             elsif ($char[$i] eq '-') {
1410 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1411 0         0 push @i, $i;
1412             }
1413             }
1414             }
1415              
1416             # open character list (reverse for splice)
1417 0         0 for my $i (CORE::reverse @i) {
1418 0         0 my @range = ();
1419              
1420             # range error
1421 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1422 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1423             }
1424              
1425             # range of multiple-octet code
1426 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1427 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1428 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1429             }
1430             elsif (CORE::length($char[$i+1]) == 2) {
1431 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1432 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1433             }
1434             elsif (CORE::length($char[$i+1]) == 3) {
1435 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1436 0         0 push @range, chars2();
1437 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1438             }
1439             elsif (CORE::length($char[$i+1]) == 4) {
1440 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1441 0         0 push @range, chars2();
1442 0         0 push @range, chars3();
1443 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1444             }
1445             else {
1446 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1447             }
1448             }
1449             elsif (CORE::length($char[$i-1]) == 2) {
1450 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1451 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1452             }
1453             elsif (CORE::length($char[$i+1]) == 3) {
1454 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1455 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1456             }
1457             elsif (CORE::length($char[$i+1]) == 4) {
1458 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1459 0         0 push @range, chars3();
1460 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1461             }
1462             else {
1463 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1464             }
1465             }
1466             elsif (CORE::length($char[$i-1]) == 3) {
1467 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1468 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1469             }
1470             elsif (CORE::length($char[$i+1]) == 4) {
1471 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1472 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1473             }
1474             else {
1475 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1476             }
1477             }
1478             elsif (CORE::length($char[$i-1]) == 4) {
1479 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1480 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1481             }
1482             else {
1483 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1484             }
1485             }
1486             else {
1487 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1488             }
1489              
1490 0         0 splice @char, $i-1, 3, @range;
1491             }
1492              
1493 0         0 return @char;
1494             }
1495              
1496             #
1497             # Latin-8 open character class
1498             #
1499             sub _cc {
1500 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1501 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1502             }
1503             elsif (scalar(@_) == 1) {
1504 0         0 return sprintf('\x%02X',$_[0]);
1505             }
1506             elsif (scalar(@_) == 2) {
1507 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1508 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1509             }
1510             elsif ($_[0] == $_[1]) {
1511 0         0 return sprintf('\x%02X',$_[0]);
1512             }
1513             elsif (($_[0]+1) == $_[1]) {
1514 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1515             }
1516             else {
1517 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1518             }
1519             }
1520             else {
1521 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1522             }
1523             }
1524              
1525             #
1526             # Latin-8 octet range
1527             #
1528             sub _octets {
1529 0     182   0 my $length = shift @_;
1530              
1531 182 50       452 if ($length == 1) {
1532 182         429 my($a1) = unpack 'C', $_[0];
1533 182         1212 my($z1) = unpack 'C', $_[1];
1534              
1535 182 50       368 if ($a1 > $z1) {
1536 182         407 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1537             }
1538              
1539 0 50       0 if ($a1 == $z1) {
    50          
1540 182         538 return sprintf('\x%02X',$a1);
1541             }
1542             elsif (($a1+1) == $z1) {
1543 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1544             }
1545             else {
1546 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1547             }
1548             }
1549             else {
1550 182         1651 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1551             }
1552             }
1553              
1554             #
1555             # Latin-8 range regexp
1556             #
1557             sub _range_regexp {
1558 0     182   0 my($length,$first,$last) = @_;
1559              
1560 182         502 my @range_regexp = ();
1561 182 50       418 if (not exists $range_tr{$length}) {
1562 182         486 return @range_regexp;
1563             }
1564              
1565 0         0 my @ranges = @{ $range_tr{$length} };
  182         316  
1566 182         489 while (my @range = splice(@ranges,0,$length)) {
1567 182         670 my $min = '';
1568 182         276 my $max = '';
1569 182         264 for (my $i=0; $i < $length; $i++) {
1570 182         520 $min .= pack 'C', $range[$i][0];
1571 182         780 $max .= pack 'C', $range[$i][-1];
1572             }
1573              
1574             # min___max
1575             # FIRST_____________LAST
1576             # (nothing)
1577              
1578 182 50 33     521 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1579             }
1580              
1581             # **********
1582             # min_________max
1583             # FIRST_____________LAST
1584             # **********
1585              
1586             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1587 182         2022 push @range_regexp, _octets($length,$first,$max,$min,$max);
1588             }
1589              
1590             # **********************
1591             # min________________max
1592             # FIRST_____________LAST
1593             # **********************
1594              
1595             elsif (($min eq $first) and ($max eq $last)) {
1596 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1597             }
1598              
1599             # *********
1600             # min___max
1601             # FIRST_____________LAST
1602             # *********
1603              
1604             elsif (($first le $min) and ($max le $last)) {
1605 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1606             }
1607              
1608             # **********************
1609             # min__________________________max
1610             # FIRST_____________LAST
1611             # **********************
1612              
1613             elsif (($min le $first) and ($last le $max)) {
1614 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1615             }
1616              
1617             # *********
1618             # min________max
1619             # FIRST_____________LAST
1620             # *********
1621              
1622             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1623 182         521 push @range_regexp, _octets($length,$min,$last,$min,$max);
1624             }
1625              
1626             # min___max
1627             # FIRST_____________LAST
1628             # (nothing)
1629              
1630             elsif ($last lt $min) {
1631             }
1632              
1633             else {
1634 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1635             }
1636             }
1637              
1638 0         0 return @range_regexp;
1639             }
1640              
1641             #
1642             # Latin-8 open character list for qr and not qr
1643             #
1644             sub _charlist {
1645              
1646 182     358   686 my $modifier = pop @_;
1647 358         586 my @char = @_;
1648              
1649 358 100       809 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1650              
1651             # unescape character
1652 358         1035 for (my $i=0; $i <= $#char; $i++) {
1653              
1654             # escape - to ...
1655 358 100 100     1346 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1656 1125 100 100     9542 if ((0 < $i) and ($i < $#char)) {
1657 206         803 $char[$i] = '...';
1658             }
1659             }
1660              
1661             # octal escape sequence
1662             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1663 182         3692 $char[$i] = octchr($1);
1664             }
1665              
1666             # hexadecimal escape sequence
1667             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1668 0         0 $char[$i] = hexchr($1);
1669             }
1670              
1671             # \b{...} --> b\{...}
1672             # \B{...} --> B\{...}
1673             # \N{CHARNAME} --> N\{CHARNAME}
1674             # \p{PROPERTY} --> p\{PROPERTY}
1675             # \P{PROPERTY} --> P\{PROPERTY}
1676             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1677 0         0 $char[$i] = $1 . '\\' . $2;
1678             }
1679              
1680             # \p, \P, \X --> p, P, X
1681             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1682 0         0 $char[$i] = $1;
1683             }
1684              
1685             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1686 0         0 $char[$i] = CORE::chr oct $1;
1687             }
1688             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1689 0         0 $char[$i] = CORE::chr hex $1;
1690             }
1691             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1692 22         105 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1693             }
1694             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1695             $char[$i] = {
1696             '\0' => "\0",
1697             '\n' => "\n",
1698             '\r' => "\r",
1699             '\t' => "\t",
1700             '\f' => "\f",
1701             '\b' => "\x08", # \b means backspace in character class
1702             '\a' => "\a",
1703             '\e' => "\e",
1704             '\d' => '[0-9]',
1705              
1706             # Vertical tabs are now whitespace
1707             # \s in a regex now matches a vertical tab in all circumstances.
1708             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1709             # \t \n \v \f \r space
1710             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1711             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1712             '\s' => '\s',
1713              
1714             '\w' => '[0-9A-Z_a-z]',
1715             '\D' => '${Elatin8::eD}',
1716             '\S' => '${Elatin8::eS}',
1717             '\W' => '${Elatin8::eW}',
1718              
1719             '\H' => '${Elatin8::eH}',
1720             '\V' => '${Elatin8::eV}',
1721             '\h' => '[\x09\x20]',
1722             '\v' => '[\x0A\x0B\x0C\x0D]',
1723             '\R' => '${Elatin8::eR}',
1724              
1725 0         0 }->{$1};
1726             }
1727              
1728             # POSIX-style character classes
1729             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1730             $char[$i] = {
1731              
1732             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1733             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1734             '[:^lower:]' => '${Elatin8::not_lower_i}',
1735             '[:^upper:]' => '${Elatin8::not_upper_i}',
1736              
1737 25         593 }->{$1};
1738             }
1739             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1740             $char[$i] = {
1741              
1742             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1743             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1744             '[:ascii:]' => '[\x00-\x7F]',
1745             '[:blank:]' => '[\x09\x20]',
1746             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1747             '[:digit:]' => '[\x30-\x39]',
1748             '[:graph:]' => '[\x21-\x7F]',
1749             '[:lower:]' => '[\x61-\x7A]',
1750             '[:print:]' => '[\x20-\x7F]',
1751             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1752              
1753             # P.174 POSIX-Style Character Classes
1754             # in Chapter 5: Pattern Matching
1755             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1756              
1757             # P.311 11.2.4 Character Classes and other Special Escapes
1758             # in Chapter 11: perlre: Perl regular expressions
1759             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1760              
1761             # P.210 POSIX-Style Character Classes
1762             # in Chapter 5: Pattern Matching
1763             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1764              
1765             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1766              
1767             '[:upper:]' => '[\x41-\x5A]',
1768             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1769             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1770             '[:^alnum:]' => '${Elatin8::not_alnum}',
1771             '[:^alpha:]' => '${Elatin8::not_alpha}',
1772             '[:^ascii:]' => '${Elatin8::not_ascii}',
1773             '[:^blank:]' => '${Elatin8::not_blank}',
1774             '[:^cntrl:]' => '${Elatin8::not_cntrl}',
1775             '[:^digit:]' => '${Elatin8::not_digit}',
1776             '[:^graph:]' => '${Elatin8::not_graph}',
1777             '[:^lower:]' => '${Elatin8::not_lower}',
1778             '[:^print:]' => '${Elatin8::not_print}',
1779             '[:^punct:]' => '${Elatin8::not_punct}',
1780             '[:^space:]' => '${Elatin8::not_space}',
1781             '[:^upper:]' => '${Elatin8::not_upper}',
1782             '[:^word:]' => '${Elatin8::not_word}',
1783             '[:^xdigit:]' => '${Elatin8::not_xdigit}',
1784              
1785 8         64 }->{$1};
1786             }
1787             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1788 70         2058 $char[$i] = $1;
1789             }
1790             }
1791              
1792             # open character list
1793 7         37 my @singleoctet = ();
1794 358         780 my @multipleoctet = ();
1795 358         503 for (my $i=0; $i <= $#char; ) {
1796              
1797             # escaped -
1798 358 100 100     28395 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1799 943         5820 $i += 1;
1800 182         256 next;
1801             }
1802              
1803             # make range regexp
1804             elsif ($char[$i] eq '...') {
1805              
1806             # range error
1807 182 50       365 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1808 182         1141 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1809             }
1810             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1811 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1812 182         580 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1813             }
1814             }
1815              
1816             # make range regexp per length
1817 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1818 182         575 my @regexp = ();
1819              
1820             # is first and last
1821 182 50 33     287 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1822 182         738 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1823             }
1824              
1825             # is first
1826             elsif ($length == CORE::length($char[$i-1])) {
1827 182         700 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1828             }
1829              
1830             # is inside in first and last
1831             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1832 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1833             }
1834              
1835             # is last
1836             elsif ($length == CORE::length($char[$i+1])) {
1837 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1838             }
1839              
1840             else {
1841 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1842             }
1843              
1844 0 50       0 if ($length == 1) {
1845 182         447 push @singleoctet, @regexp;
1846             }
1847             else {
1848 182         1315 push @multipleoctet, @regexp;
1849             }
1850             }
1851              
1852 0         0 $i += 2;
1853             }
1854              
1855             # with /i modifier
1856             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1857 182 100       438 if ($modifier =~ /i/oxms) {
1858 493         784 my $uc = Elatin8::uc($char[$i]);
1859 24         50 my $fc = Elatin8::fc($char[$i]);
1860 24 100       49 if ($uc ne $fc) {
1861 24 50       39 if (CORE::length($fc) == 1) {
1862 12         75 push @singleoctet, $uc, $fc;
1863             }
1864             else {
1865 12         201 push @singleoctet, $uc;
1866 0         0 push @multipleoctet, $fc;
1867             }
1868             }
1869             else {
1870 0         0 push @singleoctet, $char[$i];
1871             }
1872             }
1873             else {
1874 12         25 push @singleoctet, $char[$i];
1875             }
1876 469         704 $i += 1;
1877             }
1878              
1879             # single character of single octet code
1880             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1881 493         890 push @singleoctet, "\t", "\x20";
1882 0         0 $i += 1;
1883             }
1884             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1885 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1886 0         0 $i += 1;
1887             }
1888             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1889 0         0 push @singleoctet, $char[$i];
1890 2         6 $i += 1;
1891             }
1892              
1893             # single character of multiple-octet code
1894             else {
1895 2         6 push @multipleoctet, $char[$i];
1896 84         163 $i += 1;
1897             }
1898             }
1899              
1900             # quote metachar
1901 84         189 for (@singleoctet) {
1902 358 50       830 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1903 689         3201 $_ = '-';
1904             }
1905             elsif (/\A \n \z/oxms) {
1906 0         0 $_ = '\n';
1907             }
1908             elsif (/\A \r \z/oxms) {
1909 8         20 $_ = '\r';
1910             }
1911             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1912 8         24 $_ = sprintf('\x%02X', CORE::ord $1);
1913             }
1914             elsif (/\A [\x00-\xFF] \z/oxms) {
1915 60         201 $_ = quotemeta $_;
1916             }
1917             }
1918              
1919             # return character list
1920 429         623 return \@singleoctet, \@multipleoctet;
1921             }
1922              
1923             #
1924             # Latin-8 octal escape sequence
1925             #
1926             sub octchr {
1927 358     5 0 1399 my($octdigit) = @_;
1928              
1929 5         11 my @binary = ();
1930 5         11 for my $octal (split(//,$octdigit)) {
1931             push @binary, {
1932             '0' => '000',
1933             '1' => '001',
1934             '2' => '010',
1935             '3' => '011',
1936             '4' => '100',
1937             '5' => '101',
1938             '6' => '110',
1939             '7' => '111',
1940 5         19 }->{$octal};
1941             }
1942 50         201 my $binary = join '', @binary;
1943              
1944             my $octchr = {
1945             # 1234567
1946             1 => pack('B*', "0000000$binary"),
1947             2 => pack('B*', "000000$binary"),
1948             3 => pack('B*', "00000$binary"),
1949             4 => pack('B*', "0000$binary"),
1950             5 => pack('B*', "000$binary"),
1951             6 => pack('B*', "00$binary"),
1952             7 => pack('B*', "0$binary"),
1953             0 => pack('B*', "$binary"),
1954              
1955 5         16 }->{CORE::length($binary) % 8};
1956              
1957 5         64 return $octchr;
1958             }
1959              
1960             #
1961             # Latin-8 hexadecimal escape sequence
1962             #
1963             sub hexchr {
1964 5     5 0 20 my($hexdigit) = @_;
1965              
1966             my $hexchr = {
1967             1 => pack('H*', "0$hexdigit"),
1968             0 => pack('H*', "$hexdigit"),
1969              
1970 5         13 }->{CORE::length($_[0]) % 2};
1971              
1972 5         38 return $hexchr;
1973             }
1974              
1975             #
1976             # Latin-8 open character list for qr
1977             #
1978             sub charlist_qr {
1979              
1980 5     314 0 18 my $modifier = pop @_;
1981 314         645 my @char = @_;
1982              
1983 314         819 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1984 314         1071 my @singleoctet = @$singleoctet;
1985 314         729 my @multipleoctet = @$multipleoctet;
1986              
1987             # return character list
1988 314 100       486 if (scalar(@singleoctet) >= 1) {
1989              
1990             # with /i modifier
1991 314 100       980 if ($modifier =~ m/i/oxms) {
1992 236         501 my %singleoctet_ignorecase = ();
1993 22         31 for (@singleoctet) {
1994 22   100     33 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1995 46         255 for my $ord (hex($1) .. hex($2)) {
1996 46         136 my $char = CORE::chr($ord);
1997 66         102 my $uc = Elatin8::uc($char);
1998 66         104 my $fc = Elatin8::fc($char);
1999 66 100       125 if ($uc eq $fc) {
2000 66         114 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2001             }
2002             else {
2003 12 50       80 if (CORE::length($fc) == 1) {
2004 54         119 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2005 54         154 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2006             }
2007             else {
2008 54         206 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2009 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2010             }
2011             }
2012             }
2013             }
2014 0 50       0 if ($_ ne '') {
2015 46         99 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2016             }
2017             }
2018 0         0 my $i = 0;
2019 22         27 my @singleoctet_ignorecase = ();
2020 22         36 for my $ord (0 .. 255) {
2021 22 100       34 if (exists $singleoctet_ignorecase{$ord}) {
2022 5632         6865 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         88  
2023             }
2024             else {
2025 96         239 $i++;
2026             }
2027             }
2028 5536         6294 @singleoctet = ();
2029 22         41 for my $range (@singleoctet_ignorecase) {
2030 22 100       65 if (ref $range) {
2031 3648 100       6939 if (scalar(@{$range}) == 1) {
  56 50       56  
2032 56         92 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         41  
2033             }
2034 36         145 elsif (scalar(@{$range}) == 2) {
2035 20         25 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2036             }
2037             else {
2038 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         24  
  20         28  
2039             }
2040             }
2041             }
2042             }
2043              
2044 20         101 my $not_anchor = '';
2045              
2046 236         381 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2047             }
2048 236 100       720 if (scalar(@multipleoctet) >= 2) {
2049 314         730 return '(?:' . join('|', @multipleoctet) . ')';
2050             }
2051             else {
2052 6         38 return $multipleoctet[0];
2053             }
2054             }
2055              
2056             #
2057             # Latin-8 open character list for not qr
2058             #
2059             sub charlist_not_qr {
2060              
2061 308     44 0 1706 my $modifier = pop @_;
2062 44         92 my @char = @_;
2063              
2064 44         228 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2065 44         159 my @singleoctet = @$singleoctet;
2066 44         103 my @multipleoctet = @$multipleoctet;
2067              
2068             # with /i modifier
2069 44 100       65 if ($modifier =~ m/i/oxms) {
2070 44         105 my %singleoctet_ignorecase = ();
2071 10         15 for (@singleoctet) {
2072 10   66     17 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2073 10         47 for my $ord (hex($1) .. hex($2)) {
2074 10         34 my $char = CORE::chr($ord);
2075 30         48 my $uc = Elatin8::uc($char);
2076 30         43 my $fc = Elatin8::fc($char);
2077 30 50       48 if ($uc eq $fc) {
2078 30         46 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2079             }
2080             else {
2081 0 50       0 if (CORE::length($fc) == 1) {
2082 30         44 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2083 30         62 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2084             }
2085             else {
2086 30         107 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2087 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2088             }
2089             }
2090             }
2091             }
2092 0 50       0 if ($_ ne '') {
2093 10         25 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2094             }
2095             }
2096 0         0 my $i = 0;
2097 10         14 my @singleoctet_ignorecase = ();
2098 10         11 for my $ord (0 .. 255) {
2099 10 100       19 if (exists $singleoctet_ignorecase{$ord}) {
2100 2560         3058 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         56  
2101             }
2102             else {
2103 60         115 $i++;
2104             }
2105             }
2106 2500         2513 @singleoctet = ();
2107 10         16 for my $range (@singleoctet_ignorecase) {
2108 10 100       25 if (ref $range) {
2109 960 50       1491 if (scalar(@{$range}) == 1) {
  20 50       19  
2110 20         31 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2111             }
2112 0         0 elsif (scalar(@{$range}) == 2) {
2113 20         26 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2114             }
2115             else {
2116 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         21  
  20         22  
2117             }
2118             }
2119             }
2120             }
2121              
2122             # return character list
2123 20 50       76 if (scalar(@multipleoctet) >= 1) {
2124 44 0       102 if (scalar(@singleoctet) >= 1) {
2125              
2126             # any character other than multiple-octet and single octet character class
2127 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2128             }
2129             else {
2130              
2131             # any character other than multiple-octet character class
2132 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2133             }
2134             }
2135             else {
2136 0 50       0 if (scalar(@singleoctet) >= 1) {
2137              
2138             # any character other than single octet character class
2139 44         124 return '(?:[^' . join('', @singleoctet) . '])';
2140             }
2141             else {
2142              
2143             # any character
2144 44         269 return "(?:$your_char)";
2145             }
2146             }
2147             }
2148              
2149             #
2150             # open file in read mode
2151             #
2152             sub _open_r {
2153 0     408   0 my(undef,$file) = @_;
2154 204     204   2582 use Fcntl qw(O_RDONLY);
  204         1828  
  204         31538  
2155 408         1115 return CORE::sysopen($_[0], $file, &O_RDONLY);
2156             }
2157              
2158             #
2159             # open file in append mode
2160             #
2161             sub _open_a {
2162 408     204   20401 my(undef,$file) = @_;
2163 204     204   1601 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         471  
  204         786163  
2164 204         742 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2165             }
2166              
2167             #
2168             # safe system
2169             #
2170             sub _systemx {
2171              
2172             # P.707 29.2.33. exec
2173             # in Chapter 29: Functions
2174             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2175             #
2176             # Be aware that in older releases of Perl, exec (and system) did not flush
2177             # your output buffer, so you needed to enable command buffering by setting $|
2178             # on one or more filehandles to avoid lost output in the case of exec, or
2179             # misordererd output in the case of system. This situation was largely remedied
2180             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2181              
2182             # P.855 exec
2183             # in Chapter 27: Functions
2184             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2185             #
2186             # In very old release of Perl (before v5.6), exec (and system) did not flush
2187             # your output buffer, so you needed to enable command buffering by setting $|
2188             # on one or more filehandles to avoid lost output with exec or misordered
2189             # output with system.
2190              
2191 204     204   42912 $| = 1;
2192              
2193             # P.565 23.1.2. Cleaning Up Your Environment
2194             # in Chapter 23: Security
2195             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2196              
2197             # P.656 Cleaning Up Your Environment
2198             # in Chapter 20: Security
2199             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2200              
2201             # local $ENV{'PATH'} = '.';
2202 204         798 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2203              
2204             # P.707 29.2.33. exec
2205             # in Chapter 29: Functions
2206             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2207             #
2208             # As we mentioned earlier, exec treats a discrete list of arguments as an
2209             # indication that it should bypass shell processing. However, there is one
2210             # place where you might still get tripped up. The exec call (and system, too)
2211             # will not distinguish between a single scalar argument and an array containing
2212             # only one element.
2213             #
2214             # @args = ("echo surprise"); # just one element in list
2215             # exec @args # still subject to shell escapes
2216             # or die "exec: $!"; # because @args == 1
2217             #
2218             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2219             # first argument as the pathname, which forces the rest of the arguments to be
2220             # interpreted as a list, even if there is only one of them:
2221             #
2222             # exec { $args[0] } @args # safe even with one-argument list
2223             # or die "can't exec @args: $!";
2224              
2225             # P.855 exec
2226             # in Chapter 27: Functions
2227             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2228             #
2229             # As we mentioned earlier, exec treats a discrete list of arguments as a
2230             # directive to bypass shell processing. However, there is one place where
2231             # you might still get tripped up. The exec call (and system, too) cannot
2232             # distinguish between a single scalar argument and an array containing
2233             # only one element.
2234             #
2235             # @args = ("echo surprise"); # just one element in list
2236             # exec @args # still subject to shell escapes
2237             # || die "exec: $!"; # because @args == 1
2238             #
2239             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2240             # argument as the pathname, which forces the rest of the arguments to be
2241             # interpreted as a list, even if there is only one of them:
2242             #
2243             # exec { $args[0] } @args # safe even with one-argument list
2244             # || die "can't exec @args: $!";
2245              
2246 204         1787 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         528  
2247             }
2248              
2249             #
2250             # Latin-8 order to character (with parameter)
2251             #
2252             sub Elatin8::chr(;$) {
2253              
2254 204 0   0 0 21869714 my $c = @_ ? $_[0] : $_;
2255              
2256 0 0       0 if ($c == 0x00) {
2257 0         0 return "\x00";
2258             }
2259             else {
2260 0         0 my @chr = ();
2261 0         0 while ($c > 0) {
2262 0         0 unshift @chr, ($c % 0x100);
2263 0         0 $c = int($c / 0x100);
2264             }
2265 0         0 return pack 'C*', @chr;
2266             }
2267             }
2268              
2269             #
2270             # Latin-8 order to character (without parameter)
2271             #
2272             sub Elatin8::chr_() {
2273              
2274 0     0 0 0 my $c = $_;
2275              
2276 0 0       0 if ($c == 0x00) {
2277 0         0 return "\x00";
2278             }
2279             else {
2280 0         0 my @chr = ();
2281 0         0 while ($c > 0) {
2282 0         0 unshift @chr, ($c % 0x100);
2283 0         0 $c = int($c / 0x100);
2284             }
2285 0         0 return pack 'C*', @chr;
2286             }
2287             }
2288              
2289             #
2290             # Latin-8 path globbing (with parameter)
2291             #
2292             sub Elatin8::glob($) {
2293              
2294 0 0   0 0 0 if (wantarray) {
2295 0         0 my @glob = _DOS_like_glob(@_);
2296 0         0 for my $glob (@glob) {
2297 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2298             }
2299 0         0 return @glob;
2300             }
2301             else {
2302 0         0 my $glob = _DOS_like_glob(@_);
2303 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2304 0         0 return $glob;
2305             }
2306             }
2307              
2308             #
2309             # Latin-8 path globbing (without parameter)
2310             #
2311             sub Elatin8::glob_() {
2312              
2313 0 0   0 0 0 if (wantarray) {
2314 0         0 my @glob = _DOS_like_glob();
2315 0         0 for my $glob (@glob) {
2316 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2317             }
2318 0         0 return @glob;
2319             }
2320             else {
2321 0         0 my $glob = _DOS_like_glob();
2322 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2323 0         0 return $glob;
2324             }
2325             }
2326              
2327             #
2328             # Latin-8 path globbing via File::DosGlob 1.10
2329             #
2330             # Often I confuse "_dosglob" and "_doglob".
2331             # So, I renamed "_dosglob" to "_DOS_like_glob".
2332             #
2333             my %iter;
2334             my %entries;
2335             sub _DOS_like_glob {
2336              
2337             # context (keyed by second cxix argument provided by core)
2338 0     0   0 my($expr,$cxix) = @_;
2339              
2340             # glob without args defaults to $_
2341 0 0       0 $expr = $_ if not defined $expr;
2342              
2343             # represents the current user's home directory
2344             #
2345             # 7.3. Expanding Tildes in Filenames
2346             # in Chapter 7. File Access
2347             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2348             #
2349             # and File::HomeDir, File::HomeDir::Windows module
2350              
2351             # DOS-like system
2352 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2353 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2354             { my_home_MSWin32() }oxmse;
2355             }
2356              
2357             # UNIX-like system
2358 0 0 0     0 else {
  0         0  
2359             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2360             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2361             }
2362 0 0       0  
2363 0 0       0 # assume global context if not provided one
2364             $cxix = '_G_' if not defined $cxix;
2365             $iter{$cxix} = 0 if not exists $iter{$cxix};
2366 0 0       0  
2367 0         0 # if we're just beginning, do it all first
2368             if ($iter{$cxix} == 0) {
2369             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2370             }
2371 0 0       0  
2372 0         0 # chuck it all out, quick or slow
2373 0         0 if (wantarray) {
  0         0  
2374             delete $iter{$cxix};
2375             return @{delete $entries{$cxix}};
2376 0 0       0 }
  0         0  
2377 0         0 else {
  0         0  
2378             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2379             return shift @{$entries{$cxix}};
2380             }
2381 0         0 else {
2382 0         0 # return undef for EOL
2383 0         0 delete $iter{$cxix};
2384             delete $entries{$cxix};
2385             return undef;
2386             }
2387             }
2388             }
2389              
2390             #
2391             # Latin-8 path globbing subroutine
2392             #
2393 0     0   0 sub _do_glob {
2394 0         0  
2395 0         0 my($cond,@expr) = @_;
2396             my @glob = ();
2397             my $fix_drive_relative_paths = 0;
2398 0         0  
2399 0 0       0 OUTER:
2400 0 0       0 for my $expr (@expr) {
2401             next OUTER if not defined $expr;
2402 0         0 next OUTER if $expr eq '';
2403 0         0  
2404 0         0 my @matched = ();
2405 0         0 my @globdir = ();
2406 0         0 my $head = '.';
2407             my $pathsep = '/';
2408             my $tail;
2409 0 0       0  
2410 0         0 # if argument is within quotes strip em and do no globbing
2411 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2412 0 0       0 $expr = $1;
2413 0         0 if ($cond eq 'd') {
2414             if (-d $expr) {
2415             push @glob, $expr;
2416             }
2417 0 0       0 }
2418 0         0 else {
2419             if (-e $expr) {
2420             push @glob, $expr;
2421 0         0 }
2422             }
2423             next OUTER;
2424             }
2425              
2426 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2427 0 0       0 # to h:./*.pm to expand correctly
2428 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2429             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2430             $fix_drive_relative_paths = 1;
2431             }
2432 0 0       0 }
2433 0 0       0  
2434 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2435 0         0 if ($tail eq '') {
2436             push @glob, $expr;
2437 0 0       0 next OUTER;
2438 0 0       0 }
2439 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2440 0         0 if (@globdir = _do_glob('d', $head)) {
2441             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2442             next OUTER;
2443 0 0 0     0 }
2444 0         0 }
2445             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2446 0         0 $head .= $pathsep;
2447             }
2448             $expr = $tail;
2449             }
2450 0 0       0  
2451 0 0       0 # If file component has no wildcards, we can avoid opendir
2452 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2453             if ($head eq '.') {
2454 0 0 0     0 $head = '';
2455 0         0 }
2456             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2457 0         0 $head .= $pathsep;
2458 0 0       0 }
2459 0 0       0 $head .= $expr;
2460 0         0 if ($cond eq 'd') {
2461             if (-d $head) {
2462             push @glob, $head;
2463             }
2464 0 0       0 }
2465 0         0 else {
2466             if (-e $head) {
2467             push @glob, $head;
2468 0         0 }
2469             }
2470 0 0       0 next OUTER;
2471 0         0 }
2472 0         0 opendir(*DIR, $head) or next OUTER;
2473             my @leaf = readdir DIR;
2474 0 0       0 closedir DIR;
2475 0         0  
2476             if ($head eq '.') {
2477 0 0 0     0 $head = '';
2478 0         0 }
2479             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2480             $head .= $pathsep;
2481 0         0 }
2482 0         0  
2483 0         0 my $pattern = '';
2484             while ($expr =~ / \G ($q_char) /oxgc) {
2485             my $char = $1;
2486              
2487             # 6.9. Matching Shell Globs as Regular Expressions
2488             # in Chapter 6. Pattern Matching
2489             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2490 0 0       0 # (and so on)
    0          
    0          
2491 0         0  
2492             if ($char eq '*') {
2493             $pattern .= "(?:$your_char)*",
2494 0         0 }
2495             elsif ($char eq '?') {
2496             $pattern .= "(?:$your_char)?", # DOS style
2497             # $pattern .= "(?:$your_char)", # UNIX style
2498 0         0 }
2499             elsif ((my $fc = Elatin8::fc($char)) ne $char) {
2500             $pattern .= $fc;
2501 0         0 }
2502             else {
2503             $pattern .= quotemeta $char;
2504 0     0   0 }
  0         0  
2505             }
2506             my $matchsub = sub { Elatin8::fc($_[0]) =~ /\A $pattern \z/xms };
2507              
2508             # if ($@) {
2509             # print STDERR "$0: $@\n";
2510             # next OUTER;
2511             # }
2512 0         0  
2513 0 0 0     0 INNER:
2514 0         0 for my $leaf (@leaf) {
2515             if ($leaf eq '.' or $leaf eq '..') {
2516 0 0 0     0 next INNER;
2517 0         0 }
2518             if ($cond eq 'd' and not -d "$head$leaf") {
2519             next INNER;
2520 0 0       0 }
2521 0         0  
2522 0         0 if (&$matchsub($leaf)) {
2523             push @matched, "$head$leaf";
2524             next INNER;
2525             }
2526              
2527             # [DOS compatibility special case]
2528 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2529              
2530             if (Elatin8::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2531             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2532 0 0       0 Elatin8::index($pattern,'\\.') != -1 # pattern has a dot.
2533 0         0 ) {
2534 0         0 if (&$matchsub("$leaf.")) {
2535             push @matched, "$head$leaf";
2536             next INNER;
2537             }
2538 0 0       0 }
2539 0         0 }
2540             if (@matched) {
2541             push @glob, @matched;
2542 0 0       0 }
2543 0         0 }
2544 0         0 if ($fix_drive_relative_paths) {
2545             for my $glob (@glob) {
2546             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2547 0         0 }
2548             }
2549             return @glob;
2550             }
2551              
2552             #
2553             # Latin-8 parse line
2554             #
2555 0     0   0 sub _parse_line {
2556              
2557 0         0 my($line) = @_;
2558 0         0  
2559 0         0 $line .= ' ';
2560             my @piece = ();
2561             while ($line =~ /
2562             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2563             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2564 0 0       0 /oxmsg
2565             ) {
2566 0         0 push @piece, defined($1) ? $1 : $2;
2567             }
2568             return @piece;
2569             }
2570              
2571             #
2572             # Latin-8 parse path
2573             #
2574 0     0   0 sub _parse_path {
2575              
2576 0         0 my($path,$pathsep) = @_;
2577 0         0  
2578 0         0 $path .= '/';
2579             my @subpath = ();
2580             while ($path =~ /
2581             ((?: [^\/\\] )+?) [\/\\]
2582 0         0 /oxmsg
2583             ) {
2584             push @subpath, $1;
2585 0         0 }
2586 0         0  
2587 0         0 my $tail = pop @subpath;
2588             my $head = join $pathsep, @subpath;
2589             return $head, $tail;
2590             }
2591              
2592             #
2593             # via File::HomeDir::Windows 1.00
2594             #
2595             sub my_home_MSWin32 {
2596              
2597             # A lot of unix people and unix-derived tools rely on
2598 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2599 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2600             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2601             return $ENV{'HOME'};
2602             }
2603              
2604 0         0 # Do we have a user profile?
2605             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2606             return $ENV{'USERPROFILE'};
2607             }
2608              
2609 0         0 # Some Windows use something like $ENV{'HOME'}
2610             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2611             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2612 0         0 }
2613              
2614             return undef;
2615             }
2616              
2617             #
2618             # via File::HomeDir::Unix 1.00
2619 0     0 0 0 #
2620             sub my_home {
2621 0 0 0     0 my $home;
    0 0        
2622 0         0  
2623             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2624             $home = $ENV{'HOME'};
2625             }
2626              
2627             # This is from the original code, but I'm guessing
2628 0         0 # it means "login directory" and exists on some Unixes.
2629             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2630             $home = $ENV{'LOGDIR'};
2631             }
2632              
2633             ### More-desperate methods
2634              
2635 0         0 # Light desperation on any (Unixish) platform
2636             else {
2637             $home = CORE::eval q{ (getpwuid($<))[7] };
2638             }
2639              
2640 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2641 0         0 # For example, "nobody"-like users might use /nonexistant
2642             if (defined $home and ! -d($home)) {
2643 0         0 $home = undef;
2644             }
2645             return $home;
2646             }
2647              
2648             #
2649             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2650 0     0 0 0 #
2651             sub Elatin8::PREMATCH {
2652             return $`;
2653             }
2654              
2655             #
2656             # ${^MATCH}, $MATCH, $& the string that matched
2657 0     0 0 0 #
2658             sub Elatin8::MATCH {
2659             return $&;
2660             }
2661              
2662             #
2663             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2664 0     0 0 0 #
2665             sub Elatin8::POSTMATCH {
2666             return $';
2667             }
2668              
2669             #
2670             # Latin-8 character to order (with parameter)
2671             #
2672 0 0   0 1 0 sub Latin8::ord(;$) {
2673              
2674 0 0       0 local $_ = shift if @_;
2675 0         0  
2676 0         0 if (/\A ($q_char) /oxms) {
2677 0         0 my @ord = unpack 'C*', $1;
2678 0         0 my $ord = 0;
2679             while (my $o = shift @ord) {
2680 0         0 $ord = $ord * 0x100 + $o;
2681             }
2682             return $ord;
2683 0         0 }
2684             else {
2685             return CORE::ord $_;
2686             }
2687             }
2688              
2689             #
2690             # Latin-8 character to order (without parameter)
2691             #
2692 0 0   0 0 0 sub Latin8::ord_() {
2693 0         0  
2694 0         0 if (/\A ($q_char) /oxms) {
2695 0         0 my @ord = unpack 'C*', $1;
2696 0         0 my $ord = 0;
2697             while (my $o = shift @ord) {
2698 0         0 $ord = $ord * 0x100 + $o;
2699             }
2700             return $ord;
2701 0         0 }
2702             else {
2703             return CORE::ord $_;
2704             }
2705             }
2706              
2707             #
2708             # Latin-8 reverse
2709             #
2710 0 0   0 0 0 sub Latin8::reverse(@) {
2711 0         0  
2712             if (wantarray) {
2713             return CORE::reverse @_;
2714             }
2715             else {
2716              
2717             # One of us once cornered Larry in an elevator and asked him what
2718             # problem he was solving with this, but he looked as far off into
2719             # the distance as he could in an elevator and said, "It seemed like
2720 0         0 # a good idea at the time."
2721              
2722             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2723             }
2724             }
2725              
2726             #
2727             # Latin-8 getc (with parameter, without parameter)
2728             #
2729 0     0 0 0 sub Latin8::getc(;*@) {
2730 0 0       0  
2731 0 0 0     0 my($package) = caller;
2732             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2733 0         0 croak 'Too many arguments for Latin8::getc' if @_ and not wantarray;
  0         0  
2734 0         0  
2735 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2736 0         0 my $getc = '';
2737 0 0       0 for my $length ($length[0] .. $length[-1]) {
2738 0 0       0 $getc .= CORE::getc($fh);
2739 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2740             if ($getc =~ /\A ${Elatin8::dot_s} \z/oxms) {
2741             return wantarray ? ($getc,@_) : $getc;
2742             }
2743 0 0       0 }
2744             }
2745             return wantarray ? ($getc,@_) : $getc;
2746             }
2747              
2748             #
2749             # Latin-8 length by character
2750             #
2751 0 0   0 1 0 sub Latin8::length(;$) {
2752              
2753 0         0 local $_ = shift if @_;
2754 0         0  
2755             local @_ = /\G ($q_char) /oxmsg;
2756             return scalar @_;
2757             }
2758              
2759             #
2760             # Latin-8 substr by character
2761             #
2762             BEGIN {
2763              
2764             # P.232 The lvalue Attribute
2765             # in Chapter 6: Subroutines
2766             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2767              
2768             # P.336 The lvalue Attribute
2769             # in Chapter 7: Subroutines
2770             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2771              
2772             # P.144 8.4 Lvalue subroutines
2773             # in Chapter 8: perlsub: Perl subroutines
2774 204 50 0 204 1 192424 # 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  
2775              
2776             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2777             # vv----------------------*******
2778             sub Latin8::substr($$;$$) %s {
2779              
2780             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2781              
2782             # If the substring is beyond either end of the string, substr() returns the undefined
2783             # value and produces a warning. When used as an lvalue, specifying a substring that
2784             # is entirely outside the string raises an exception.
2785             # http://perldoc.perl.org/functions/substr.html
2786              
2787             # A return with no argument returns the scalar value undef in scalar context,
2788             # an empty list () in list context, and (naturally) nothing at all in void
2789             # context.
2790              
2791             my $offset = $_[1];
2792             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2793             return;
2794             }
2795              
2796             # substr($string,$offset,$length,$replacement)
2797             if (@_ == 4) {
2798             my(undef,undef,$length,$replacement) = @_;
2799             my $substr = join '', splice(@char, $offset, $length, $replacement);
2800             $_[0] = join '', @char;
2801              
2802             # return $substr; this doesn't work, don't say "return"
2803             $substr;
2804             }
2805              
2806             # substr($string,$offset,$length)
2807             elsif (@_ == 3) {
2808             my(undef,undef,$length) = @_;
2809             my $octet_offset = 0;
2810             my $octet_length = 0;
2811             if ($offset == 0) {
2812             $octet_offset = 0;
2813             }
2814             elsif ($offset > 0) {
2815             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2816             }
2817             else {
2818             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2819             }
2820             if ($length == 0) {
2821             $octet_length = 0;
2822             }
2823             elsif ($length > 0) {
2824             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2825             }
2826             else {
2827             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2828             }
2829             CORE::substr($_[0], $octet_offset, $octet_length);
2830             }
2831              
2832             # substr($string,$offset)
2833             else {
2834             my $octet_offset = 0;
2835             if ($offset == 0) {
2836             $octet_offset = 0;
2837             }
2838             elsif ($offset > 0) {
2839             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2840             }
2841             else {
2842             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2843             }
2844             CORE::substr($_[0], $octet_offset);
2845             }
2846             }
2847             END
2848             }
2849              
2850             #
2851             # Latin-8 index by character
2852             #
2853 0     0 1 0 sub Latin8::index($$;$) {
2854 0 0       0  
2855 0         0 my $index;
2856             if (@_ == 3) {
2857             $index = Elatin8::index($_[0], $_[1], CORE::length(Latin8::substr($_[0], 0, $_[2])));
2858 0         0 }
2859             else {
2860             $index = Elatin8::index($_[0], $_[1]);
2861 0 0       0 }
2862 0         0  
2863             if ($index == -1) {
2864             return -1;
2865 0         0 }
2866             else {
2867             return Latin8::length(CORE::substr $_[0], 0, $index);
2868             }
2869             }
2870              
2871             #
2872             # Latin-8 rindex by character
2873             #
2874 0     0 1 0 sub Latin8::rindex($$;$) {
2875 0 0       0  
2876 0         0 my $rindex;
2877             if (@_ == 3) {
2878             $rindex = Elatin8::rindex($_[0], $_[1], CORE::length(Latin8::substr($_[0], 0, $_[2])));
2879 0         0 }
2880             else {
2881             $rindex = Elatin8::rindex($_[0], $_[1]);
2882 0 0       0 }
2883 0         0  
2884             if ($rindex == -1) {
2885             return -1;
2886 0         0 }
2887             else {
2888             return Latin8::length(CORE::substr $_[0], 0, $rindex);
2889             }
2890             }
2891              
2892 204     204   2070 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         481  
  204         24822  
2893             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2894             use vars qw($slash); $slash = 'm//';
2895              
2896             # ord() to ord() or Latin8::ord()
2897             my $function_ord = 'ord';
2898              
2899             # ord to ord or Latin8::ord_
2900             my $function_ord_ = 'ord';
2901              
2902             # reverse to reverse or Latin8::reverse
2903             my $function_reverse = 'reverse';
2904              
2905             # getc to getc or Latin8::getc
2906             my $function_getc = 'getc';
2907              
2908             # P.1023 Appendix W.9 Multibyte Anchoring
2909             # of ISBN 1-56592-224-7 CJKV Information Processing
2910              
2911 204     204   2098 my $anchor = '';
  204     0   483  
  204         10827024  
2912              
2913             use vars qw($nest);
2914              
2915             # regexp of nested parens in qqXX
2916              
2917             # P.340 Matching Nested Constructs with Embedded Code
2918             # in Chapter 7: Perl
2919             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2920              
2921             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2922             [^\\()] |
2923             \( (?{$nest++}) |
2924             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2925             \\ [^c] |
2926             \\c[\x40-\x5F] |
2927             [\x00-\xFF]
2928             }xms;
2929              
2930             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2931             [^\\{}] |
2932             \{ (?{$nest++}) |
2933             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2934             \\ [^c] |
2935             \\c[\x40-\x5F] |
2936             [\x00-\xFF]
2937             }xms;
2938              
2939             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2940             [^\\\[\]] |
2941             \[ (?{$nest++}) |
2942             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2943             \\ [^c] |
2944             \\c[\x40-\x5F] |
2945             [\x00-\xFF]
2946             }xms;
2947              
2948             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2949             [^\\<>] |
2950             \< (?{$nest++}) |
2951             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2952             \\ [^c] |
2953             \\c[\x40-\x5F] |
2954             [\x00-\xFF]
2955             }xms;
2956              
2957             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2958             (?: ::)? (?:
2959             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2960             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2961             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2962             ))
2963             }xms;
2964              
2965             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2966             (?: ::)? (?:
2967             (?>[0-9]+) |
2968             [^a-zA-Z_0-9\[\]] |
2969             ^[A-Z] |
2970             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2971             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2972             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2973             ))
2974             }xms;
2975              
2976             my $qq_substr = qr{(?> Char::substr | Latin8::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2977             }xms;
2978              
2979             # regexp of nested parens in qXX
2980             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2981             [^()] |
2982             \( (?{$nest++}) |
2983             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2984             [\x00-\xFF]
2985             }xms;
2986              
2987             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2988             [^\{\}] |
2989             \{ (?{$nest++}) |
2990             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2991             [\x00-\xFF]
2992             }xms;
2993              
2994             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2995             [^\[\]] |
2996             \[ (?{$nest++}) |
2997             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2998             [\x00-\xFF]
2999             }xms;
3000              
3001             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3002             [^<>] |
3003             \< (?{$nest++}) |
3004             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3005             [\x00-\xFF]
3006             }xms;
3007              
3008             my $matched = '';
3009             my $s_matched = '';
3010              
3011             my $tr_variable = ''; # variable of tr///
3012             my $sub_variable = ''; # variable of s///
3013             my $bind_operator = ''; # =~ or !~
3014              
3015             my @heredoc = (); # here document
3016             my @heredoc_delimiter = ();
3017             my $here_script = ''; # here script
3018              
3019             #
3020             # escape Latin-8 script
3021 0 50   204 0 0 #
3022             sub Latin8::escape(;$) {
3023             local($_) = $_[0] if @_;
3024              
3025             # P.359 The Study Function
3026             # in Chapter 7: Perl
3027 204         610 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3028              
3029             study $_; # Yes, I studied study yesterday.
3030              
3031             # while all script
3032              
3033             # 6.14. Matching from Where the Last Pattern Left Off
3034             # in Chapter 6. Pattern Matching
3035             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3036             # (and so on)
3037              
3038             # one member of Tag-team
3039             #
3040             # P.128 Start of match (or end of previous match): \G
3041             # P.130 Advanced Use of \G with Perl
3042             # in Chapter 3: Overview of Regular Expression Features and Flavors
3043             # P.255 Use leading anchors
3044             # P.256 Expose ^ and \G at the front expressions
3045             # in Chapter 6: Crafting an Efficient Expression
3046             # P.315 "Tag-team" matching with /gc
3047             # in Chapter 7: Perl
3048 204         642 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3049 204         422  
3050 204         723 my $e_script = '';
3051             while (not /\G \z/oxgc) { # member
3052             $e_script .= Latin8::escape_token();
3053 75097         166795 }
3054              
3055             return $e_script;
3056             }
3057              
3058             #
3059             # escape Latin-8 token of script
3060             #
3061             sub Latin8::escape_token {
3062              
3063 204     75097 0 3986 # \n output here document
3064              
3065             my $ignore_modules = join('|', qw(
3066             utf8
3067             bytes
3068             charnames
3069             I18N::Japanese
3070             I18N::Collate
3071             I18N::JExt
3072             File::DosGlob
3073             Wild
3074             Wildcard
3075             Japanese
3076             ));
3077              
3078             # another member of Tag-team
3079             #
3080             # P.315 "Tag-team" matching with /gc
3081             # in Chapter 7: Perl
3082 75097 100 100     111116 # 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          
3083 75097         3430945  
3084 12544 100       35897 if (/\G ( \n ) /oxgc) { # another member (and so on)
3085 12544         23374 my $heredoc = '';
3086             if (scalar(@heredoc_delimiter) >= 1) {
3087 174         221 $slash = 'm//';
3088 174         382  
3089             $heredoc = join '', @heredoc;
3090             @heredoc = ();
3091 174         299  
3092 174         300 # skip here document
3093             for my $heredoc_delimiter (@heredoc_delimiter) {
3094 174         1048 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3095             }
3096 174         514 @heredoc_delimiter = ();
3097              
3098 174         257 $here_script = '';
3099             }
3100             return "\n" . $heredoc;
3101             }
3102 12544         54977  
3103             # ignore space, comment
3104             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3105              
3106             # if (, elsif (, unless (, while (, until (, given (, and when (
3107              
3108             # given, when
3109              
3110             # P.225 The given Statement
3111             # in Chapter 15: Smart Matching and given-when
3112             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3113              
3114             # P.133 The given Statement
3115             # in Chapter 4: Statements and Declarations
3116             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3117 18084         60720  
3118 1401         2749 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3119             $slash = 'm//';
3120             return $1;
3121             }
3122              
3123             # scalar variable ($scalar = ...) =~ tr///;
3124             # scalar variable ($scalar = ...) =~ s///;
3125              
3126             # state
3127              
3128             # P.68 Persistent, Private Variables
3129             # in Chapter 4: Subroutines
3130             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3131              
3132             # P.160 Persistent Lexically Scoped Variables: state
3133             # in Chapter 4: Statements and Declarations
3134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3135              
3136             # (and so on)
3137 1401         4442  
3138             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3139 86 50       211 my $e_string = e_string($1);
    50          
3140 86         3379  
3141 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3142 0         0 $tr_variable = $e_string . e_string($1);
3143 0         0 $bind_operator = $2;
3144             $slash = 'm//';
3145             return '';
3146 0         0 }
3147 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3148 0         0 $sub_variable = $e_string . e_string($1);
3149 0         0 $bind_operator = $2;
3150             $slash = 'm//';
3151             return '';
3152 0         0 }
3153 86         168 else {
3154             $slash = 'div';
3155             return $e_string;
3156             }
3157             }
3158              
3159 86         297 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
3160 4         9 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3161             $slash = 'div';
3162             return q{Elatin8::PREMATCH()};
3163             }
3164              
3165 4         15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
3166 28         69 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3167             $slash = 'div';
3168             return q{Elatin8::MATCH()};
3169             }
3170              
3171 28         90 # $', ${'} --> $', ${'}
3172 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3173             $slash = 'div';
3174             return $1;
3175             }
3176              
3177 1         5 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
3178 3         9 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3179             $slash = 'div';
3180             return q{Elatin8::POSTMATCH()};
3181             }
3182              
3183             # scalar variable $scalar =~ tr///;
3184             # scalar variable $scalar =~ s///;
3185             # substr() =~ tr///;
3186 3         10 # substr() =~ s///;
3187             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3188 1671 100       5508 my $scalar = e_string($1);
    100          
3189 1671         7939  
3190 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3191 1         3 $tr_variable = $scalar;
3192 1         3 $bind_operator = $1;
3193             $slash = 'm//';
3194             return '';
3195 1         3 }
3196 61         119 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3197 61         115 $sub_variable = $scalar;
3198 61         96 $bind_operator = $1;
3199             $slash = 'm//';
3200             return '';
3201 61         186 }
3202 1609         2354 else {
3203             $slash = 'div';
3204             return $scalar;
3205             }
3206             }
3207              
3208 1609         4273 # end of statement
3209             elsif (/\G ( [,;] ) /oxgc) {
3210             $slash = 'm//';
3211 5020         22415  
3212             # clear tr/// variable
3213             $tr_variable = '';
3214 5020         6135  
3215             # clear s/// variable
3216 5020         5704 $sub_variable = '';
3217              
3218 5020         5815 $bind_operator = '';
3219              
3220             return $1;
3221             }
3222              
3223 5020         17747 # bareword
3224             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3225             return $1;
3226             }
3227              
3228 0         0 # $0 --> $0
3229 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3230             $slash = 'div';
3231             return $1;
3232 2         7 }
3233 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3234             $slash = 'div';
3235             return $1;
3236             }
3237              
3238 0         0 # $$ --> $$
3239 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3240             $slash = 'div';
3241             return $1;
3242             }
3243              
3244             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3245 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3246 4         6 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3247             $slash = 'div';
3248             return e_capture($1);
3249 4         8 }
3250 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3251             $slash = 'div';
3252             return e_capture($1);
3253             }
3254              
3255 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3256 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3257             $slash = 'div';
3258             return e_capture($1.'->'.$2);
3259             }
3260              
3261 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3262 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3263             $slash = 'div';
3264             return e_capture($1.'->'.$2);
3265             }
3266              
3267 0         0 # $$foo
3268 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3269             $slash = 'div';
3270             return e_capture($1);
3271             }
3272              
3273 0         0 # ${ foo }
3274 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3275             $slash = 'div';
3276             return '${' . $1 . '}';
3277             }
3278              
3279 0         0 # ${ ... }
3280 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3281             $slash = 'div';
3282             return e_capture($1);
3283             }
3284              
3285             # variable or function
3286 0         0 # $ @ % & * $ #
3287 42         71 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) {
3288             $slash = 'div';
3289             return $1;
3290             }
3291             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3292 42         127 # $ @ # \ ' " / ? ( ) [ ] < >
3293 62         138 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3294             $slash = 'div';
3295             return $1;
3296             }
3297              
3298 62         204 # while ()
3299             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3300             return $1;
3301             }
3302              
3303             # while () --- glob
3304              
3305             # avoid "Error: Runtime exception" of perl version 5.005_03
3306 0         0  
3307             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3308             return 'while ($_ = Elatin8::glob("' . $1 . '"))';
3309             }
3310              
3311 0         0 # while (glob)
3312             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3313             return 'while ($_ = Elatin8::glob_)';
3314             }
3315              
3316 0         0 # while (glob(WILDCARD))
3317             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3318             return 'while ($_ = Elatin8::glob';
3319             }
3320 0         0  
  248         607  
3321             # doit if, doit unless, doit while, doit until, doit for, doit when
3322             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3323 248         1097  
  19         35  
3324 19         79 # subroutines of package Elatin8
  0         0  
3325 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         28  
3326 13         36 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3327 0         0 elsif (/\G \b Latin8::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         163  
3328 114         344 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         6  
3329 2         8 elsif (/\G \b Latin8::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin8::escape'; }
  0         0  
3330 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
3331 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::chop'; }
  0         0  
3332 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3333 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3334 0         0 elsif (/\G \b Latin8::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin8::index'; }
  2         5  
3335 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::index'; }
  0         0  
3336 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3337 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3338 0         0 elsif (/\G \b Latin8::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin8::rindex'; }
  1         2  
3339 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::rindex'; }
  0         0  
3340 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::lc'; }
  1         3  
3341 1         4 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::lcfirst'; }
  0         0  
3342 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::uc'; }
  6         8  
3343             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::ucfirst'; }
3344             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::fc'; }
3345 6         19  
  0         0  
3346 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3347 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3348 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3349 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3350 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3351 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3352             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3353 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  
3354 0         0  
  0         0  
3355 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3356 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3357 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3358 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3359 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3360             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3361             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3362 0         0  
  0         0  
3363 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3364 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3365 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3366             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3367 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         5  
3368 2         7  
  2         5  
3369 2         5 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         68  
3370 36         109 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3371 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::chr'; }
  8         16  
3372 8         25 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3373 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3374 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::glob'; }
  0         0  
3375 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::lc_'; }
  0         0  
3376 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::lcfirst_'; }
  0         0  
3377 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::uc_'; }
  0         0  
3378 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::ucfirst_'; }
  0         0  
3379             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::fc_'; }
3380 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3381 0         0  
  0         0  
3382 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3383 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3384 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::chr_'; }
  0         0  
3385 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3386 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3387 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::glob_'; }
  8         22  
3388             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3389             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3390 8         27 # split
3391             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3392 87         213 $slash = 'm//';
3393 87         156  
3394 87         367 my $e = '';
3395             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3396             $e .= $1;
3397             }
3398 85 100       356  
  87 100       7575  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3399             # end of split
3400             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin8::split' . $e; }
3401 2         11  
3402             # split scalar value
3403             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin8::split' . $e . e_string($1); }
3404 1         7  
3405 0         0 # split literal space
3406 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin8::split' . $e . qq {qq$1 $2}; }
3407 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3408 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3409 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3410 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3411 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3412 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin8::split' . $e . qq {q$1 $2}; }
3413 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3414 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3415 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3416 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3417 10         55 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3418             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin8::split' . $e . qq {' '}; }
3419             elsif (/\G " [ ] " /oxgc) { return 'Elatin8::split' . $e . qq {" "}; }
3420              
3421 0 0       0 # split qq//
  0         0  
3422             elsif (/\G \b (qq) \b /oxgc) {
3423 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3424 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3425 0         0 while (not /\G \z/oxgc) {
3426 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3427 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3428 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3429 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3430 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3431             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3432 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3433             }
3434             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3435             }
3436             }
3437              
3438 0 50       0 # split qr//
  12         490  
3439             elsif (/\G \b (qr) \b /oxgc) {
3440 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3441 12 50       66 else {
  12 50       3270  
    50          
    50          
    50          
    50          
    50          
    50          
3442 0         0 while (not /\G \z/oxgc) {
3443 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3444 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3445 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3446 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3447 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3448 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3449             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3450 12         89 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3451             }
3452             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3453             }
3454             }
3455              
3456 0 0       0 # split q//
  0         0  
3457             elsif (/\G \b (q) \b /oxgc) {
3458 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3459 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3460 0         0 while (not /\G \z/oxgc) {
3461 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3462 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3463 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3464 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3465 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3466             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3467 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3468             }
3469             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3470             }
3471             }
3472              
3473 0 50       0 # split m//
  18         511  
3474             elsif (/\G \b (m) \b /oxgc) {
3475 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3476 18 50       86 else {
  18 50       4990  
    50          
    50          
    50          
    50          
    50          
    50          
3477 0         0 while (not /\G \z/oxgc) {
3478 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3479 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3480 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3481 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3482 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3483 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3484             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3485 18         109 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3486             }
3487             die __FILE__, ": Search pattern not terminated\n";
3488             }
3489             }
3490              
3491 0         0 # split ''
3492 0         0 elsif (/\G (\') /oxgc) {
3493 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3494 0         0 while (not /\G \z/oxgc) {
3495 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3496 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3497             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3498 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3499             }
3500             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3501             }
3502              
3503 0         0 # split ""
3504 0         0 elsif (/\G (\") /oxgc) {
3505 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3506 0         0 while (not /\G \z/oxgc) {
3507 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3508 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3509             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3510 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3511             }
3512             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3513             }
3514              
3515 0         0 # split //
3516 44         133 elsif (/\G (\/) /oxgc) {
3517 44 50       267 my $regexp = '';
  381 50       1689  
    100          
    50          
3518 0         0 while (not /\G \z/oxgc) {
3519 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3520 44         232 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3521             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3522 337         1082 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3523             }
3524             die __FILE__, ": Search pattern not terminated\n";
3525             }
3526             }
3527              
3528             # tr/// or y///
3529              
3530             # about [cdsrbB]* (/B modifier)
3531             #
3532             # P.559 appendix C
3533             # of ISBN 4-89052-384-7 Programming perl
3534             # (Japanese title is: Perl puroguramingu)
3535 0         0  
3536             elsif (/\G \b ( tr | y ) \b /oxgc) {
3537             my $ope = $1;
3538 3 50       8  
3539 3         50 # $1 $2 $3 $4 $5 $6
3540 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3541             my @tr = ($tr_variable,$2);
3542             return e_tr(@tr,'',$4,$6);
3543 0         0 }
3544 3         5 else {
3545 3 50       8 my $e = '';
  3 50       224  
    50          
    50          
    50          
    50          
3546             while (not /\G \z/oxgc) {
3547 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3548 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3549 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3550 0         0 while (not /\G \z/oxgc) {
3551 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3552 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3553 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3554 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3555             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3556 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3557             }
3558             die __FILE__, ": Transliteration replacement not terminated\n";
3559 0         0 }
3560 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3561 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3562 0         0 while (not /\G \z/oxgc) {
3563 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3564 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3565 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3566 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3567             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3568 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3569             }
3570             die __FILE__, ": Transliteration replacement not terminated\n";
3571 0         0 }
3572 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3573 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3574 0         0 while (not /\G \z/oxgc) {
3575 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3576 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3577 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3578 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3579             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3580 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3581             }
3582             die __FILE__, ": Transliteration replacement not terminated\n";
3583 0         0 }
3584 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3585 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3586 0         0 while (not /\G \z/oxgc) {
3587 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3588 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3589 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3590 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3591             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3592 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3593             }
3594             die __FILE__, ": Transliteration replacement not terminated\n";
3595             }
3596 0         0 # $1 $2 $3 $4 $5 $6
3597 3         12 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3598             my @tr = ($tr_variable,$2);
3599             return e_tr(@tr,'',$4,$6);
3600 3         9 }
3601             }
3602             die __FILE__, ": Transliteration pattern not terminated\n";
3603             }
3604             }
3605              
3606 0         0 # qq//
3607             elsif (/\G \b (qq) \b /oxgc) {
3608             my $ope = $1;
3609 2180 50       5287  
3610 2180         4312 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3611 0         0 if (/\G (\#) /oxgc) { # qq# #
3612 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3613 0         0 while (not /\G \z/oxgc) {
3614 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3615 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3616             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3617 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3618             }
3619             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3620             }
3621 0         0  
3622 2180         3408 else {
3623 2180 50       8036 my $e = '';
  2180 50       8761  
    100          
    50          
    50          
    0          
3624             while (not /\G \z/oxgc) {
3625             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3626              
3627 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3628 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3629 0         0 my $qq_string = '';
3630 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3631 0         0 while (not /\G \z/oxgc) {
3632 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3633             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3634 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3635 0         0 elsif (/\G (\)) /oxgc) {
3636             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3637 0         0 else { $qq_string .= $1; }
3638             }
3639 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3640             }
3641             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3642             }
3643              
3644 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3645 2150         2875 elsif (/\G (\{) /oxgc) { # qq { }
3646 2150         3502 my $qq_string = '';
3647 2150 100       6419 local $nest = 1;
  84006 50       286368  
    100          
    100          
    50          
3648 722         1606 while (not /\G \z/oxgc) {
3649 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1564  
3650             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3651 1153 100       1983 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         4946  
3652 2150         5650 elsif (/\G (\}) /oxgc) {
3653             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3654 1153         2414 else { $qq_string .= $1; }
3655             }
3656 78828         184154 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3657             }
3658             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3659             }
3660              
3661 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3662 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3663 0         0 my $qq_string = '';
3664 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3665 0         0 while (not /\G \z/oxgc) {
3666 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3667             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3668 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3669 0         0 elsif (/\G (\]) /oxgc) {
3670             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3671 0         0 else { $qq_string .= $1; }
3672             }
3673 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3674             }
3675             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3676             }
3677              
3678 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3679 30         56 elsif (/\G (\<) /oxgc) { # qq < >
3680 30         68 my $qq_string = '';
3681 30 100       98 local $nest = 1;
  1166 50       3971  
    50          
    100          
    50          
3682 22         54 while (not /\G \z/oxgc) {
3683 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3684             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3685 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         66  
3686 30         72 elsif (/\G (\>) /oxgc) {
3687             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3688 0         0 else { $qq_string .= $1; }
3689             }
3690 1114         2135 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3691             }
3692             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3693             }
3694              
3695 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3696 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3697 0         0 my $delimiter = $1;
3698 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3699 0         0 while (not /\G \z/oxgc) {
3700 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3701 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3702             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3703 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3704             }
3705             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3706 0         0 }
3707             }
3708             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3709             }
3710             }
3711              
3712 0         0 # qr//
3713 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3714 0         0 my $ope = $1;
3715             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3716             return e_qr($ope,$1,$3,$2,$4);
3717 0         0 }
3718 0         0 else {
3719 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3720 0         0 while (not /\G \z/oxgc) {
3721 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3722 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3723 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3724 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3725 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3726 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3727             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3728 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3729             }
3730             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3731             }
3732             }
3733              
3734 0         0 # qw//
3735 16 50       46 elsif (/\G \b (qw) \b /oxgc) {
3736 16         77 my $ope = $1;
3737             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3738             return e_qw($ope,$1,$3,$2);
3739 0         0 }
3740 16         52 else {
3741 16 50       68 my $e = '';
  16 50       100  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3742             while (not /\G \z/oxgc) {
3743 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3744 16         72  
3745             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3746 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3747 0         0  
3748             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3749 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3750 0         0  
3751             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3752 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3753 0         0  
3754             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3755 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3756 0         0  
3757             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3758 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3759             }
3760             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3761             }
3762             }
3763              
3764 0         0 # qx//
3765 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3766 0         0 my $ope = $1;
3767             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3768             return e_qq($ope,$1,$3,$2);
3769 0         0 }
3770 0         0 else {
3771 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3772 0         0 while (not /\G \z/oxgc) {
3773 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3774 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3775 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3776 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3777 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3778             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3779 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3780             }
3781             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3782             }
3783             }
3784              
3785 0         0 # q//
3786             elsif (/\G \b (q) \b /oxgc) {
3787             my $ope = $1;
3788              
3789             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3790              
3791             # avoid "Error: Runtime exception" of perl version 5.005_03
3792 410 50       1169 # (and so on)
3793 410         1287  
3794 0         0 if (/\G (\#) /oxgc) { # q# #
3795 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3796 0         0 while (not /\G \z/oxgc) {
3797 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3798 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3799             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3800 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3801             }
3802             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3803             }
3804 0         0  
3805 410         695 else {
3806 410 50       1561 my $e = '';
  410 50       2296  
    100          
    50          
    100          
    50          
3807             while (not /\G \z/oxgc) {
3808             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3809              
3810 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3811 0         0 elsif (/\G (\() /oxgc) { # q ( )
3812 0         0 my $q_string = '';
3813 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3814 0         0 while (not /\G \z/oxgc) {
3815 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3816 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3817             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3818 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3819 0         0 elsif (/\G (\)) /oxgc) {
3820             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3821 0         0 else { $q_string .= $1; }
3822             }
3823 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3824             }
3825             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3826             }
3827              
3828 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3829 404         1007 elsif (/\G (\{) /oxgc) { # q { }
3830 404         754 my $q_string = '';
3831 404 50       1258 local $nest = 1;
  6770 50       27628  
    50          
    100          
    100          
    50          
3832 0         0 while (not /\G \z/oxgc) {
3833 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3834 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         152  
3835             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3836 107 100       187 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1484  
3837 404         1157 elsif (/\G (\}) /oxgc) {
3838             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3839 107         225 else { $q_string .= $1; }
3840             }
3841 6152         12709 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3842             }
3843             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3844             }
3845              
3846 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3847 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3848 0         0 my $q_string = '';
3849 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3850 0         0 while (not /\G \z/oxgc) {
3851 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3852 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3853             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3854 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3855 0         0 elsif (/\G (\]) /oxgc) {
3856             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3857 0         0 else { $q_string .= $1; }
3858             }
3859 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3860             }
3861             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3862             }
3863              
3864 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3865 5         14 elsif (/\G (\<) /oxgc) { # q < >
3866 5         10 my $q_string = '';
3867 5 50       18 local $nest = 1;
  88 50       370  
    50          
    50          
    100          
    50          
3868 0         0 while (not /\G \z/oxgc) {
3869 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3870 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3871             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3872 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         14  
3873 5         29 elsif (/\G (\>) /oxgc) {
3874             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3875 0         0 else { $q_string .= $1; }
3876             }
3877 83         157 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3878             }
3879             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3880             }
3881              
3882 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3883 1         2 elsif (/\G (\S) /oxgc) { # q * *
3884 1         3 my $delimiter = $1;
3885 1 50       4 my $q_string = '';
  14 50       94  
    100          
    50          
3886 0         0 while (not /\G \z/oxgc) {
3887 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3888 1         2 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3889             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3890 13         26 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3891             }
3892             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3893 0         0 }
3894             }
3895             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3896             }
3897             }
3898              
3899 0         0 # m//
3900 209 50       571 elsif (/\G \b (m) \b /oxgc) {
3901 209         1505 my $ope = $1;
3902             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3903             return e_qr($ope,$1,$3,$2,$4);
3904 0         0 }
3905 209         341 else {
3906 209 50       620 my $e = '';
  209 50       12937  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3907 0         0 while (not /\G \z/oxgc) {
3908 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3909 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3910 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3911 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3912 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3913 10         31 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3914 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3915             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3916 199         728 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3917             }
3918             die __FILE__, ": Search pattern not terminated\n";
3919             }
3920             }
3921              
3922             # s///
3923              
3924             # about [cegimosxpradlunbB]* (/cg modifier)
3925             #
3926             # P.67 Pattern-Matching Operators
3927             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3928 0         0  
3929             elsif (/\G \b (s) \b /oxgc) {
3930             my $ope = $1;
3931 97 100       262  
3932 97         1800 # $1 $2 $3 $4 $5 $6
3933             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3934             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3935 1         6 }
3936 96         187 else {
3937 96 50       300 my $e = '';
  96 50       34924  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3938             while (not /\G \z/oxgc) {
3939 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3940 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3941 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3942             while (not /\G \z/oxgc) {
3943 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3944 0         0 # $1 $2 $3 $4
3945 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954             }
3955             die __FILE__, ": Substitution replacement not terminated\n";
3956 0         0 }
3957 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3958 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3959             while (not /\G \z/oxgc) {
3960 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3961 0         0 # $1 $2 $3 $4
3962 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971             }
3972             die __FILE__, ": Substitution replacement not terminated\n";
3973 0         0 }
3974 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3975 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3976             while (not /\G \z/oxgc) {
3977 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3978 0         0 # $1 $2 $3 $4
3979 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3984             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3985 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3986             }
3987             die __FILE__, ": Substitution replacement not terminated\n";
3988 0         0 }
3989 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3990 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3991             while (not /\G \z/oxgc) {
3992 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3993 0         0 # $1 $2 $3 $4
3994 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3995 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3997 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3998 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3999 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4000 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4001             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4002 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4003             }
4004             die __FILE__, ": Substitution replacement not terminated\n";
4005             }
4006 0         0 # $1 $2 $3 $4 $5 $6
4007             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4008             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4009             }
4010 21         63 # $1 $2 $3 $4 $5 $6
4011             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4012             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4013             }
4014 0         0 # $1 $2 $3 $4 $5 $6
4015             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4016             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4017             }
4018 0         0 # $1 $2 $3 $4 $5 $6
4019             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4020             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4021 75         352 }
4022             }
4023             die __FILE__, ": Substitution pattern not terminated\n";
4024             }
4025             }
4026 0         0  
4027 0         0 # require ignore module
4028 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4029             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4030             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4031 0         0  
4032 37         320 # use strict; --> use strict; no strict qw(refs);
4033 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4034             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4035             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4036              
4037 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4038 2         23 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4039             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4040             return "use $1; no strict qw(refs);";
4041 0         0 }
4042             else {
4043             return "use $1;";
4044             }
4045 2 0 0     11 }
      0        
4046 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4047             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4048             return "use $1; no strict qw(refs);";
4049 0         0 }
4050             else {
4051             return "use $1;";
4052             }
4053             }
4054 0         0  
4055 2         20 # ignore use module
4056 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4057             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4058             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4059 0         0  
4060 0         0 # ignore no module
4061 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4062             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4063             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4064 0         0  
4065             # use else
4066             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4067 0         0  
4068             # use else
4069             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4070              
4071 2         10 # ''
4072 848         2032 elsif (/\G (?
4073 848 100       2499 my $q_string = '';
  8254 100       29050  
    100          
    50          
4074 4         11 while (not /\G \z/oxgc) {
4075 48         82 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4076 848         1989 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4077             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4078 7354         18700 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4079             }
4080             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4081             }
4082              
4083 0         0 # ""
4084 1848         4271 elsif (/\G (\") /oxgc) {
4085 1848 100       6865 my $qq_string = '';
  35409 100       123485  
    100          
    50          
4086 67         155 while (not /\G \z/oxgc) {
4087 12         26 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4088 1848         5181 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4089             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4090 33482         85880 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4091             }
4092             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4093             }
4094              
4095 0         0 # ``
4096 1         3 elsif (/\G (\`) /oxgc) {
4097 1 50       3 my $qx_string = '';
  19 50       68  
    100          
    50          
4098 0         0 while (not /\G \z/oxgc) {
4099 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4100 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4101             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4102 18         31 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4103             }
4104             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4105             }
4106              
4107 0         0 # // --- not divide operator (num / num), not defined-or
4108 453         1591 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4109 453 50       1324 my $regexp = '';
  4496 50       15707  
    100          
    50          
4110 0         0 while (not /\G \z/oxgc) {
4111 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4112 453         2119 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4113             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4114 4043         8830 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4115             }
4116             die __FILE__, ": Search pattern not terminated\n";
4117             }
4118              
4119 0         0 # ?? --- not conditional operator (condition ? then : else)
4120 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4121 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4122 0         0 while (not /\G \z/oxgc) {
4123 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4124 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4125             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4126 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4127             }
4128             die __FILE__, ": Search pattern not terminated\n";
4129             }
4130 0         0  
  0         0  
4131             # <<>> (a safer ARGV)
4132             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4133 0         0  
  0         0  
4134             # << (bit shift) --- not here document
4135             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4136              
4137 0         0 # <<~'HEREDOC'
4138 6         9 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4139 6         13 $slash = 'm//';
4140             my $here_quote = $1;
4141             my $delimiter = $2;
4142 6 50       8  
4143 6         11 # get here document
4144 6         29 if ($here_script eq '') {
4145             $here_script = CORE::substr $_, pos $_;
4146 6 50       28 $here_script =~ s/.*?\n//oxm;
4147 6         60 }
4148 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4149 6         7 my $heredoc = $1;
4150 6         45 my $indent = $2;
4151 6         19 $heredoc =~ s{^$indent}{}msg; # no /ox
4152             push @heredoc, $heredoc . qq{\n$delimiter\n};
4153             push @heredoc_delimiter, qq{\\s*$delimiter};
4154 6         11 }
4155             else {
4156 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4157             }
4158             return qq{<<'$delimiter'};
4159             }
4160              
4161             # <<~\HEREDOC
4162              
4163             # P.66 2.6.6. "Here" Documents
4164             # in Chapter 2: Bits and Pieces
4165             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4166              
4167             # P.73 "Here" Documents
4168             # in Chapter 2: Bits and Pieces
4169             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4170 6         25  
4171 3         6 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4172 3         7 $slash = 'm//';
4173             my $here_quote = $1;
4174             my $delimiter = $2;
4175 3 50       5  
4176 3         7 # get here document
4177 3         11 if ($here_script eq '') {
4178             $here_script = CORE::substr $_, pos $_;
4179 3 50       22 $here_script =~ s/.*?\n//oxm;
4180 3         36 }
4181 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4182 3         4 my $heredoc = $1;
4183 3         33 my $indent = $2;
4184 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4185             push @heredoc, $heredoc . qq{\n$delimiter\n};
4186             push @heredoc_delimiter, qq{\\s*$delimiter};
4187 3         8 }
4188             else {
4189 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4190             }
4191             return qq{<<\\$delimiter};
4192             }
4193              
4194 3         11 # <<~"HEREDOC"
4195 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4196 6         22 $slash = 'm//';
4197             my $here_quote = $1;
4198             my $delimiter = $2;
4199 6 50       9  
4200 6         11 # get here document
4201 6         19 if ($here_script eq '') {
4202             $here_script = CORE::substr $_, pos $_;
4203 6 50       28 $here_script =~ s/.*?\n//oxm;
4204 6         60 }
4205 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4206 6         10 my $heredoc = $1;
4207 6         46 my $indent = $2;
4208 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4209             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4210             push @heredoc_delimiter, qq{\\s*$delimiter};
4211 6         14 }
4212             else {
4213 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4214             }
4215             return qq{<<"$delimiter"};
4216             }
4217              
4218 6         22 # <<~HEREDOC
4219 3         8 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4220 3         7 $slash = 'm//';
4221             my $here_quote = $1;
4222             my $delimiter = $2;
4223 3 50       6  
4224 3         8 # get here document
4225 3         19 if ($here_script eq '') {
4226             $here_script = CORE::substr $_, pos $_;
4227 3 50       16 $here_script =~ s/.*?\n//oxm;
4228 3         46 }
4229 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4230 3         4 my $heredoc = $1;
4231 3         37 my $indent = $2;
4232 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4233             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4234             push @heredoc_delimiter, qq{\\s*$delimiter};
4235 3         7 }
4236             else {
4237 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4238             }
4239             return qq{<<$delimiter};
4240             }
4241              
4242 3         13 # <<~`HEREDOC`
4243 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4244 6         11 $slash = 'm//';
4245             my $here_quote = $1;
4246             my $delimiter = $2;
4247 6 50       10  
4248 6         12 # get here document
4249 6         18 if ($here_script eq '') {
4250             $here_script = CORE::substr $_, pos $_;
4251 6 50       38 $here_script =~ s/.*?\n//oxm;
4252 6         56 }
4253 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4254 6         7 my $heredoc = $1;
4255 6         200 my $indent = $2;
4256 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4257             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4258             push @heredoc_delimiter, qq{\\s*$delimiter};
4259 6         14 }
4260             else {
4261 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4262             }
4263             return qq{<<`$delimiter`};
4264             }
4265              
4266 6         25 # <<'HEREDOC'
4267 72         169 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4268 72         134 $slash = 'm//';
4269             my $here_quote = $1;
4270             my $delimiter = $2;
4271 72 50       105  
4272 72         131 # get here document
4273 72         338 if ($here_script eq '') {
4274             $here_script = CORE::substr $_, pos $_;
4275 72 50       409 $here_script =~ s/.*?\n//oxm;
4276 72         635 }
4277 72         231 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4278             push @heredoc, $1 . qq{\n$delimiter\n};
4279             push @heredoc_delimiter, $delimiter;
4280 72         112 }
4281             else {
4282 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4283             }
4284             return $here_quote;
4285             }
4286              
4287             # <<\HEREDOC
4288              
4289             # P.66 2.6.6. "Here" Documents
4290             # in Chapter 2: Bits and Pieces
4291             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4292              
4293             # P.73 "Here" Documents
4294             # in Chapter 2: Bits and Pieces
4295             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4296 72         289  
4297 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4298 0         0 $slash = 'm//';
4299             my $here_quote = $1;
4300             my $delimiter = $2;
4301 0 0       0  
4302 0         0 # get here document
4303 0         0 if ($here_script eq '') {
4304             $here_script = CORE::substr $_, pos $_;
4305 0 0       0 $here_script =~ s/.*?\n//oxm;
4306 0         0 }
4307 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4308             push @heredoc, $1 . qq{\n$delimiter\n};
4309             push @heredoc_delimiter, $delimiter;
4310 0         0 }
4311             else {
4312 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4313             }
4314             return $here_quote;
4315             }
4316              
4317 0         0 # <<"HEREDOC"
4318 36         78 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4319 36         240 $slash = 'm//';
4320             my $here_quote = $1;
4321             my $delimiter = $2;
4322 36 50       63  
4323 36         94 # get here document
4324 36         254 if ($here_script eq '') {
4325             $here_script = CORE::substr $_, pos $_;
4326 36 50       201 $here_script =~ s/.*?\n//oxm;
4327 36         602 }
4328 36         122 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4329             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4330             push @heredoc_delimiter, $delimiter;
4331 36         77 }
4332             else {
4333 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4334             }
4335             return $here_quote;
4336             }
4337              
4338 36         156 # <
4339 42         100 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4340 42         99 $slash = 'm//';
4341             my $here_quote = $1;
4342             my $delimiter = $2;
4343 42 50       85  
4344 42         119 # get here document
4345 42         367 if ($here_script eq '') {
4346             $here_script = CORE::substr $_, pos $_;
4347 42 50       332 $here_script =~ s/.*?\n//oxm;
4348 42         594 }
4349 42         151 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4350             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4351             push @heredoc_delimiter, $delimiter;
4352 42         104 }
4353             else {
4354 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4355             }
4356             return $here_quote;
4357             }
4358              
4359 42         183 # <<`HEREDOC`
4360 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4361 0         0 $slash = 'm//';
4362             my $here_quote = $1;
4363             my $delimiter = $2;
4364 0 0       0  
4365 0         0 # get here document
4366 0         0 if ($here_script eq '') {
4367             $here_script = CORE::substr $_, pos $_;
4368 0 0       0 $here_script =~ s/.*?\n//oxm;
4369 0         0 }
4370 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4371             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4372             push @heredoc_delimiter, $delimiter;
4373 0         0 }
4374             else {
4375 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4376             }
4377             return $here_quote;
4378             }
4379              
4380 0         0 # <<= <=> <= < operator
4381             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4382             return $1;
4383             }
4384              
4385 12         67 #
4386             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4387             return $1;
4388             }
4389              
4390             # --- glob
4391              
4392             # avoid "Error: Runtime exception" of perl version 5.005_03
4393 0         0  
4394             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4395             return 'Elatin8::glob("' . $1 . '")';
4396             }
4397 0         0  
4398             # __DATA__
4399             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4400 0         0  
4401             # __END__
4402             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4403              
4404             # \cD Control-D
4405              
4406             # P.68 2.6.8. Other Literal Tokens
4407             # in Chapter 2: Bits and Pieces
4408             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4409              
4410             # P.76 Other Literal Tokens
4411             # in Chapter 2: Bits and Pieces
4412 204         1549 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4413              
4414             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4415 0         0  
4416             # \cZ Control-Z
4417             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4418              
4419             # any operator before div
4420             elsif (/\G (
4421             -- | \+\+ |
4422 0         0 [\)\}\]]
  5081         11384  
4423              
4424             ) /oxgc) { $slash = 'div'; return $1; }
4425              
4426             # yada-yada or triple-dot operator
4427             elsif (/\G (
4428 5081         25087 \.\.\.
  7         13  
4429              
4430             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4431              
4432             # any operator before m//
4433              
4434             # //, //= (defined-or)
4435              
4436             # P.164 Logical Operators
4437             # in Chapter 10: More Control Structures
4438             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4439              
4440             # P.119 C-Style Logical (Short-Circuit) Operators
4441             # in Chapter 3: Unary and Binary Operators
4442             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4443              
4444             # (and so on)
4445              
4446             # ~~
4447              
4448             # P.221 The Smart Match Operator
4449             # in Chapter 15: Smart Matching and given-when
4450             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4451              
4452             # P.112 Smartmatch Operator
4453             # in Chapter 3: Unary and Binary Operators
4454             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4455              
4456             # (and so on)
4457              
4458             elsif (/\G ((?>
4459              
4460             !~~ | !~ | != | ! |
4461             %= | % |
4462             &&= | && | &= | &\.= | &\. | & |
4463             -= | -> | - |
4464             :(?>\s*)= |
4465             : |
4466             <<>> |
4467             <<= | <=> | <= | < |
4468             == | => | =~ | = |
4469             >>= | >> | >= | > |
4470             \*\*= | \*\* | \*= | \* |
4471             \+= | \+ |
4472             \.\. | \.= | \. |
4473             \/\/= | \/\/ |
4474             \/= | \/ |
4475             \? |
4476             \\ |
4477             \^= | \^\.= | \^\. | \^ |
4478             \b x= |
4479             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4480             ~~ | ~\. | ~ |
4481             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4482             \b(?: print )\b |
4483              
4484 7         27 [,;\(\{\[]
  8868         19961  
4485              
4486             )) /oxgc) { $slash = 'm//'; return $1; }
4487 8868         45824  
  15137         32230  
4488             # other any character
4489             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4490              
4491 15137         80174 # system error
4492             else {
4493             die __FILE__, ": Oops, this shouldn't happen!\n";
4494             }
4495             }
4496              
4497 0     1786 0 0 # escape Latin-8 string
4498 1786         4275 sub e_string {
4499             my($string) = @_;
4500 1786         3330 my $e_string = '';
4501              
4502             local $slash = 'm//';
4503              
4504             # P.1024 Appendix W.10 Multibyte Processing
4505             # of ISBN 1-56592-224-7 CJKV Information Processing
4506 1786         2974 # (and so on)
4507              
4508             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4509 1786 100 66     17471  
4510 1786 50       9108 # without { ... }
4511 1769         6174 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4512             if ($string !~ /<
4513             return $string;
4514             }
4515             }
4516 1769         5551  
4517 17 50       223 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          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4518             while ($string !~ /\G \z/oxgc) {
4519             if (0) {
4520             }
4521 190         12752  
4522 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin8::PREMATCH()]}
4523 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4524             $e_string .= q{Elatin8::PREMATCH()};
4525             $slash = 'div';
4526             }
4527              
4528 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin8::MATCH()]}
4529 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4530             $e_string .= q{Elatin8::MATCH()};
4531             $slash = 'div';
4532             }
4533              
4534 0         0 # $', ${'} --> $', ${'}
4535 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4536             $e_string .= $1;
4537             $slash = 'div';
4538             }
4539              
4540 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin8::POSTMATCH()]}
4541 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4542             $e_string .= q{Elatin8::POSTMATCH()};
4543             $slash = 'div';
4544             }
4545              
4546 0         0 # bareword
4547 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4548             $e_string .= $1;
4549             $slash = 'div';
4550             }
4551              
4552 0         0 # $0 --> $0
4553 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4554             $e_string .= $1;
4555             $slash = 'div';
4556 0         0 }
4557 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4558             $e_string .= $1;
4559             $slash = 'div';
4560             }
4561              
4562 0         0 # $$ --> $$
4563 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4564             $e_string .= $1;
4565             $slash = 'div';
4566             }
4567              
4568             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4569 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4570 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4571             $e_string .= e_capture($1);
4572             $slash = 'div';
4573 0         0 }
4574 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4575             $e_string .= e_capture($1);
4576             $slash = 'div';
4577             }
4578              
4579 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4580 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4581             $e_string .= e_capture($1.'->'.$2);
4582             $slash = 'div';
4583             }
4584              
4585 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4586 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4587             $e_string .= e_capture($1.'->'.$2);
4588             $slash = 'div';
4589             }
4590              
4591 0         0 # $$foo
4592 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4593             $e_string .= e_capture($1);
4594             $slash = 'div';
4595             }
4596              
4597 0         0 # ${ foo }
4598 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4599             $e_string .= '${' . $1 . '}';
4600             $slash = 'div';
4601             }
4602              
4603 0         0 # ${ ... }
4604 3         18 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4605             $e_string .= e_capture($1);
4606             $slash = 'div';
4607             }
4608              
4609             # variable or function
4610 3         16 # $ @ % & * $ #
4611 7         24 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) {
4612             $e_string .= $1;
4613             $slash = 'div';
4614             }
4615             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4616 7         21 # $ @ # \ ' " / ? ( ) [ ] < >
4617 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4618             $e_string .= $1;
4619             $slash = 'div';
4620             }
4621 0         0  
  0         0  
4622 0         0 # subroutines of package Elatin8
  0         0  
4623 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4624 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4625 0         0 elsif ($string =~ /\G \b Latin8::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4626 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4627 0         0 elsif ($string =~ /\G \b Latin8::eval \b /oxgc) { $e_string .= 'eval Latin8::escape'; $slash = 'm//'; }
  0         0  
4628 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4629 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin8::chop'; $slash = 'm//'; }
  0         0  
4630 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4631 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4632 0         0 elsif ($string =~ /\G \b Latin8::index \b /oxgc) { $e_string .= 'Latin8::index'; $slash = 'm//'; }
  0         0  
4633 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin8::index'; $slash = 'm//'; }
  0         0  
4634 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4635 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4636 0         0 elsif ($string =~ /\G \b Latin8::rindex \b /oxgc) { $e_string .= 'Latin8::rindex'; $slash = 'm//'; }
  0         0  
4637 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin8::rindex'; $slash = 'm//'; }
  0         0  
4638 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::lc'; $slash = 'm//'; }
  0         0  
4639 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::lcfirst'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::uc'; $slash = 'm//'; }
  0         0  
4641             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::ucfirst'; $slash = 'm//'; }
4642             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::fc'; $slash = 'm//'; }
4643 0         0  
  0         0  
4644 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4645 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4646 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4647 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4648 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4649 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4650             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4651 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4652 0         0  
  0         0  
4653 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4654 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4655 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4656 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4657 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4658             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4659             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4660 0         0  
  0         0  
4661 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4662 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4663 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4664             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4665 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4666 0         0  
  0         0  
4667 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4668 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4669 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::chr'; $slash = 'm//'; }
  0         0  
4670 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4671 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::glob'; $slash = 'm//'; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin8::lc_'; $slash = 'm//'; }
  0         0  
4674 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin8::lcfirst_'; $slash = 'm//'; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin8::uc_'; $slash = 'm//'; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin8::ucfirst_'; $slash = 'm//'; }
  0         0  
4677             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin8::fc_'; $slash = 'm//'; }
4678 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4679 0         0  
  0         0  
4680 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4681 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4682 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin8::chr_'; $slash = 'm//'; }
  0         0  
4683 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4684 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4685 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin8::glob_'; $slash = 'm//'; }
  0         0  
4686             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4687             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4688 0         0 # split
4689             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4690 0         0 $slash = 'm//';
4691 0         0  
4692 0         0 my $e = '';
4693             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4694             $e .= $1;
4695             }
4696 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          
4697             # end of split
4698             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin8::split' . $e; }
4699 0         0  
  0         0  
4700             # split scalar value
4701             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin8::split' . $e . e_string($1); next E_STRING_LOOP; }
4702 0         0  
  0         0  
4703 0         0 # split literal space
  0         0  
4704 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4705 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4706 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4707 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4708 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4709 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4710 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4711 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4712 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4713 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4714 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4715 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4716             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {' '}; next E_STRING_LOOP; }
4717             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {" "}; next E_STRING_LOOP; }
4718              
4719 0 0       0 # split qq//
  0         0  
  0         0  
4720             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4721 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4722 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4723 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4724 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4725 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4726 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4727 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4728 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4729             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4730 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
4731             }
4732             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4733             }
4734             }
4735              
4736 0 0       0 # split qr//
  0         0  
  0         0  
4737             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4738 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4739 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4740 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4741 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4742 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4743 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4744 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4745 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4746 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4747             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4748 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
4749             }
4750             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4751             }
4752             }
4753              
4754 0 0       0 # split q//
  0         0  
  0         0  
4755             elsif ($string =~ /\G \b (q) \b /oxgc) {
4756 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4757 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4758 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4759 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4760 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4761 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4762 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4763 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4764             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4765 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
4766             }
4767             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4768             }
4769             }
4770              
4771 0 0       0 # split m//
  0         0  
  0         0  
4772             elsif ($string =~ /\G \b (m) \b /oxgc) {
4773 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
4774 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4775 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4776 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4777 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4778 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4779 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4780 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4781 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4782             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4783 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
4784             }
4785             die __FILE__, ": Search pattern not terminated\n";
4786             }
4787             }
4788              
4789 0         0 # split ''
4790 0         0 elsif ($string =~ /\G (\') /oxgc) {
4791 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4792 0         0 while ($string !~ /\G \z/oxgc) {
4793 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4794 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4795             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4796 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4797             }
4798             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4799             }
4800              
4801 0         0 # split ""
4802 0         0 elsif ($string =~ /\G (\") /oxgc) {
4803 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4804 0         0 while ($string !~ /\G \z/oxgc) {
4805 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4806 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4807             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4808 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4809             }
4810             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4811             }
4812              
4813 0         0 # split //
4814 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4815 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4816 0         0 while ($string !~ /\G \z/oxgc) {
4817 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4818 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4819             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4820 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4821             }
4822             die __FILE__, ": Search pattern not terminated\n";
4823             }
4824             }
4825              
4826 0         0 # qq//
4827 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4828 0         0 my $ope = $1;
4829             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4830             $e_string .= e_qq($ope,$1,$3,$2);
4831 0         0 }
4832 0         0 else {
4833 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4834 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4835 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4836 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4837 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4838 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4839             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4840 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4841             }
4842             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4843             }
4844             }
4845              
4846 0         0 # qx//
4847 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4848 0         0 my $ope = $1;
4849             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4850             $e_string .= e_qq($ope,$1,$3,$2);
4851 0         0 }
4852 0         0 else {
4853 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4854 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4855 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4856 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4857 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4858 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4859 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4860             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4861 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4862             }
4863             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4864             }
4865             }
4866              
4867 0         0 # q//
4868 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4869 0         0 my $ope = $1;
4870             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4871             $e_string .= e_q($ope,$1,$3,$2);
4872 0         0 }
4873 0         0 else {
4874 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4875 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4876 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4877 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4878 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4879 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4880             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4881 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 * *
4882             }
4883             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4884             }
4885             }
4886 0         0  
4887             # ''
4888             elsif ($string =~ /\G (?
4889 0         0  
4890             # ""
4891             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4892 0         0  
4893             # ``
4894             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4895 0         0  
4896             # <<>> (a safer ARGV)
4897             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4898 0         0  
4899             # <<= <=> <= < operator
4900             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4901 0         0  
4902             #
4903             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4904              
4905 0         0 # --- glob
4906             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4907             $e_string .= 'Elatin8::glob("' . $1 . '")';
4908             }
4909              
4910 0         0 # << (bit shift) --- not here document
4911 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4912             $slash = 'm//';
4913             $e_string .= $1;
4914             }
4915              
4916 0         0 # <<~'HEREDOC'
4917 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4918 0         0 $slash = 'm//';
4919             my $here_quote = $1;
4920             my $delimiter = $2;
4921 0 0       0  
4922 0         0 # get here document
4923 0         0 if ($here_script eq '') {
4924             $here_script = CORE::substr $_, pos $_;
4925 0 0       0 $here_script =~ s/.*?\n//oxm;
4926 0         0 }
4927 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4928 0         0 my $heredoc = $1;
4929 0         0 my $indent = $2;
4930 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4931             push @heredoc, $heredoc . qq{\n$delimiter\n};
4932             push @heredoc_delimiter, qq{\\s*$delimiter};
4933 0         0 }
4934             else {
4935 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4936             }
4937             $e_string .= qq{<<'$delimiter'};
4938             }
4939              
4940 0         0 # <<~\HEREDOC
4941 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4942 0         0 $slash = 'm//';
4943             my $here_quote = $1;
4944             my $delimiter = $2;
4945 0 0       0  
4946 0         0 # get here document
4947 0         0 if ($here_script eq '') {
4948             $here_script = CORE::substr $_, pos $_;
4949 0 0       0 $here_script =~ s/.*?\n//oxm;
4950 0         0 }
4951 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4952 0         0 my $heredoc = $1;
4953 0         0 my $indent = $2;
4954 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4955             push @heredoc, $heredoc . qq{\n$delimiter\n};
4956             push @heredoc_delimiter, qq{\\s*$delimiter};
4957 0         0 }
4958             else {
4959 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4960             }
4961             $e_string .= qq{<<\\$delimiter};
4962             }
4963              
4964 0         0 # <<~"HEREDOC"
4965 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4966 0         0 $slash = 'm//';
4967             my $here_quote = $1;
4968             my $delimiter = $2;
4969 0 0       0  
4970 0         0 # get here document
4971 0         0 if ($here_script eq '') {
4972             $here_script = CORE::substr $_, pos $_;
4973 0 0       0 $here_script =~ s/.*?\n//oxm;
4974 0         0 }
4975 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4976 0         0 my $heredoc = $1;
4977 0         0 my $indent = $2;
4978 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4979             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4980             push @heredoc_delimiter, qq{\\s*$delimiter};
4981 0         0 }
4982             else {
4983 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4984             }
4985             $e_string .= qq{<<"$delimiter"};
4986             }
4987              
4988 0         0 # <<~HEREDOC
4989 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4990 0         0 $slash = 'm//';
4991             my $here_quote = $1;
4992             my $delimiter = $2;
4993 0 0       0  
4994 0         0 # get here document
4995 0         0 if ($here_script eq '') {
4996             $here_script = CORE::substr $_, pos $_;
4997 0 0       0 $here_script =~ s/.*?\n//oxm;
4998 0         0 }
4999 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5000 0         0 my $heredoc = $1;
5001 0         0 my $indent = $2;
5002 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5003             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5004             push @heredoc_delimiter, qq{\\s*$delimiter};
5005 0         0 }
5006             else {
5007 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5008             }
5009             $e_string .= qq{<<$delimiter};
5010             }
5011              
5012 0         0 # <<~`HEREDOC`
5013 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
5014 0         0 $slash = 'm//';
5015             my $here_quote = $1;
5016             my $delimiter = $2;
5017 0 0       0  
5018 0         0 # get here document
5019 0         0 if ($here_script eq '') {
5020             $here_script = CORE::substr $_, pos $_;
5021 0 0       0 $here_script =~ s/.*?\n//oxm;
5022 0         0 }
5023 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5024 0         0 my $heredoc = $1;
5025 0         0 my $indent = $2;
5026 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5027             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5028             push @heredoc_delimiter, qq{\\s*$delimiter};
5029 0         0 }
5030             else {
5031 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5032             }
5033             $e_string .= qq{<<`$delimiter`};
5034             }
5035              
5036 0         0 # <<'HEREDOC'
5037 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5038 0         0 $slash = 'm//';
5039             my $here_quote = $1;
5040             my $delimiter = $2;
5041 0 0       0  
5042 0         0 # get here document
5043 0         0 if ($here_script eq '') {
5044             $here_script = CORE::substr $_, pos $_;
5045 0 0       0 $here_script =~ s/.*?\n//oxm;
5046 0         0 }
5047 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5048             push @heredoc, $1 . qq{\n$delimiter\n};
5049             push @heredoc_delimiter, $delimiter;
5050 0         0 }
5051             else {
5052 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5053             }
5054             $e_string .= $here_quote;
5055             }
5056              
5057 0         0 # <<\HEREDOC
5058 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5059 0         0 $slash = 'm//';
5060             my $here_quote = $1;
5061             my $delimiter = $2;
5062 0 0       0  
5063 0         0 # get here document
5064 0         0 if ($here_script eq '') {
5065             $here_script = CORE::substr $_, pos $_;
5066 0 0       0 $here_script =~ s/.*?\n//oxm;
5067 0         0 }
5068 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5069             push @heredoc, $1 . qq{\n$delimiter\n};
5070             push @heredoc_delimiter, $delimiter;
5071 0         0 }
5072             else {
5073 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5074             }
5075             $e_string .= $here_quote;
5076             }
5077              
5078 0         0 # <<"HEREDOC"
5079 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5080 0         0 $slash = 'm//';
5081             my $here_quote = $1;
5082             my $delimiter = $2;
5083 0 0       0  
5084 0         0 # get here document
5085 0         0 if ($here_script eq '') {
5086             $here_script = CORE::substr $_, pos $_;
5087 0 0       0 $here_script =~ s/.*?\n//oxm;
5088 0         0 }
5089 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5090             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5091             push @heredoc_delimiter, $delimiter;
5092 0         0 }
5093             else {
5094 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5095             }
5096             $e_string .= $here_quote;
5097             }
5098              
5099 0         0 # <
5100 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5101 0         0 $slash = 'm//';
5102             my $here_quote = $1;
5103             my $delimiter = $2;
5104 0 0       0  
5105 0         0 # get here document
5106 0         0 if ($here_script eq '') {
5107             $here_script = CORE::substr $_, pos $_;
5108 0 0       0 $here_script =~ s/.*?\n//oxm;
5109 0         0 }
5110 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5111             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5112             push @heredoc_delimiter, $delimiter;
5113 0         0 }
5114             else {
5115 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5116             }
5117             $e_string .= $here_quote;
5118             }
5119              
5120 0         0 # <<`HEREDOC`
5121 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5122 0         0 $slash = 'm//';
5123             my $here_quote = $1;
5124             my $delimiter = $2;
5125 0 0       0  
5126 0         0 # get here document
5127 0         0 if ($here_script eq '') {
5128             $here_script = CORE::substr $_, pos $_;
5129 0 0       0 $here_script =~ s/.*?\n//oxm;
5130 0         0 }
5131 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5132             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5133             push @heredoc_delimiter, $delimiter;
5134 0         0 }
5135             else {
5136 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5137             }
5138             $e_string .= $here_quote;
5139             }
5140              
5141             # any operator before div
5142             elsif ($string =~ /\G (
5143             -- | \+\+ |
5144 0         0 [\)\}\]]
  18         33  
5145              
5146             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5147              
5148             # yada-yada or triple-dot operator
5149             elsif ($string =~ /\G (
5150 18         58 \.\.\.
  0         0  
5151              
5152             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5153              
5154             # any operator before m//
5155             elsif ($string =~ /\G ((?>
5156              
5157             !~~ | !~ | != | ! |
5158             %= | % |
5159             &&= | && | &= | &\.= | &\. | & |
5160             -= | -> | - |
5161             :(?>\s*)= |
5162             : |
5163             <<>> |
5164             <<= | <=> | <= | < |
5165             == | => | =~ | = |
5166             >>= | >> | >= | > |
5167             \*\*= | \*\* | \*= | \* |
5168             \+= | \+ |
5169             \.\. | \.= | \. |
5170             \/\/= | \/\/ |
5171             \/= | \/ |
5172             \? |
5173             \\ |
5174             \^= | \^\.= | \^\. | \^ |
5175             \b x= |
5176             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5177             ~~ | ~\. | ~ |
5178             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5179             \b(?: print )\b |
5180              
5181 0         0 [,;\(\{\[]
  31         61  
5182              
5183             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5184 31         105  
5185             # other any character
5186             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5187              
5188 131         508 # system error
5189             else {
5190             die __FILE__, ": Oops, this shouldn't happen!\n";
5191             }
5192 0         0 }
5193              
5194             return $e_string;
5195             }
5196              
5197             #
5198             # character class
5199 17     1919 0 71 #
5200             sub character_class {
5201 1919 100       3458 my($char,$modifier) = @_;
5202 1919 100       3032  
5203 52         108 if ($char eq '.') {
5204             if ($modifier =~ /s/) {
5205             return '${Elatin8::dot_s}';
5206 17         39 }
5207             else {
5208             return '${Elatin8::dot}';
5209             }
5210 35         73 }
5211             else {
5212             return Elatin8::classic_character_class($char);
5213             }
5214             }
5215              
5216             #
5217             # escape capture ($1, $2, $3, ...)
5218             #
5219 1867     212 0 3204 sub e_capture {
5220              
5221             return join '', '${', $_[0], '}';
5222             }
5223              
5224             #
5225             # escape transliteration (tr/// or y///)
5226 212     3 0 762 #
5227 3         17 sub e_tr {
5228 3   50     5 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5229             my $e_tr = '';
5230 3         7 $modifier ||= '';
5231              
5232             $slash = 'div';
5233 3         4  
5234             # quote character class 1
5235             $charclass = q_tr($charclass);
5236 3         6  
5237             # quote character class 2
5238             $charclass2 = q_tr($charclass2);
5239 3 50       8  
5240 3 0       15 # /b /B modifier
5241 0         0 if ($modifier =~ tr/bB//d) {
5242             if ($variable eq '') {
5243             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5244 0         0 }
5245             else {
5246             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5247             }
5248 0 100       0 }
5249 3         6 else {
5250             if ($variable eq '') {
5251             $e_tr = qq{Elatin8::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5252 2         8 }
5253             else {
5254             $e_tr = qq{Elatin8::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5255             }
5256             }
5257 1         5  
5258 3         5 # clear tr/// variable
5259             $tr_variable = '';
5260 3         4 $bind_operator = '';
5261              
5262             return $e_tr;
5263             }
5264              
5265             #
5266             # quote for escape transliteration (tr/// or y///)
5267 3     6 0 16 #
5268             sub q_tr {
5269             my($charclass) = @_;
5270 6 50       9  
    0          
    0          
    0          
    0          
    0          
5271 6         14 # quote character class
5272             if ($charclass !~ /'/oxms) {
5273             return e_q('', "'", "'", $charclass); # --> q' '
5274 6         8 }
5275             elsif ($charclass !~ /\//oxms) {
5276             return e_q('q', '/', '/', $charclass); # --> q/ /
5277 0         0 }
5278             elsif ($charclass !~ /\#/oxms) {
5279             return e_q('q', '#', '#', $charclass); # --> q# #
5280 0         0 }
5281             elsif ($charclass !~ /[\<\>]/oxms) {
5282             return e_q('q', '<', '>', $charclass); # --> q< >
5283 0         0 }
5284             elsif ($charclass !~ /[\(\)]/oxms) {
5285             return e_q('q', '(', ')', $charclass); # --> q( )
5286 0         0 }
5287             elsif ($charclass !~ /[\{\}]/oxms) {
5288             return e_q('q', '{', '}', $charclass); # --> q{ }
5289 0         0 }
5290 0 0       0 else {
5291 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5292             if ($charclass !~ /\Q$char\E/xms) {
5293             return e_q('q', $char, $char, $charclass);
5294             }
5295             }
5296 0         0 }
5297              
5298             return e_q('q', '{', '}', $charclass);
5299             }
5300              
5301             #
5302             # escape q string (q//, '')
5303 0     1264 0 0 #
5304             sub e_q {
5305 1264         16615 my($ope,$delimiter,$end_delimiter,$string) = @_;
5306              
5307 1264         2005 $slash = 'div';
5308              
5309             return join '', $ope, $delimiter, $string, $end_delimiter;
5310             }
5311              
5312             #
5313             # escape qq string (qq//, "", qx//, ``)
5314 1264     4110 0 8929 #
5315             sub e_qq {
5316 4110         11347 my($ope,$delimiter,$end_delimiter,$string) = @_;
5317              
5318 4110         6186 $slash = 'div';
5319 4110         6047  
5320             my $left_e = 0;
5321             my $right_e = 0;
5322 4110         8733  
5323             # split regexp
5324             my @char = $string =~ /\G((?>
5325             [^\\\$] |
5326             \\x\{ (?>[0-9A-Fa-f]+) \} |
5327             \\o\{ (?>[0-7]+) \} |
5328             \\N\{ (?>[^0-9\}][^\}]*) \} |
5329             \\ $q_char |
5330             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5331             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5332             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5333             \$ (?>\s* [0-9]+) |
5334             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5335             \$ \$ (?![\w\{]) |
5336             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5337             $q_char
5338 4110         274592 ))/oxmsg;
5339              
5340             for (my $i=0; $i <= $#char; $i++) {
5341 4110 50 33     15745  
    50 33        
    100          
    100          
    50          
5342 113973         386807 # "\L\u" --> "\u\L"
5343             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5344             @char[$i,$i+1] = @char[$i+1,$i];
5345             }
5346              
5347 0         0 # "\U\l" --> "\l\U"
5348             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5349             @char[$i,$i+1] = @char[$i+1,$i];
5350             }
5351              
5352 0         0 # octal escape sequence
5353             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5354             $char[$i] = Elatin8::octchr($1);
5355             }
5356              
5357 1         6 # hexadecimal escape sequence
5358             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5359             $char[$i] = Elatin8::hexchr($1);
5360             }
5361              
5362 1         4 # \N{CHARNAME} --> N{CHARNAME}
5363             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5364             $char[$i] = $1;
5365 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          
5366              
5367             if (0) {
5368             }
5369              
5370             # \F
5371             #
5372             # P.69 Table 2-6. Translation escapes
5373             # in Chapter 2: Bits and Pieces
5374             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5375             # (and so on)
5376 113973         1111938  
5377 0 50       0 # \u \l \U \L \F \Q \E
5378 484         1113 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5379             if ($right_e < $left_e) {
5380             $char[$i] = '\\' . $char[$i];
5381             }
5382             }
5383             elsif ($char[$i] eq '\u') {
5384              
5385             # "STRING @{[ LIST EXPR ]} MORE STRING"
5386              
5387             # P.257 Other Tricks You Can Do with Hard References
5388             # in Chapter 8: References
5389             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5390              
5391             # P.353 Other Tricks You Can Do with Hard References
5392             # in Chapter 8: References
5393             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5394              
5395 0         0 # (and so on)
5396 0         0  
5397             $char[$i] = '@{[Elatin8::ucfirst qq<';
5398             $left_e++;
5399 0         0 }
5400 0         0 elsif ($char[$i] eq '\l') {
5401             $char[$i] = '@{[Elatin8::lcfirst qq<';
5402             $left_e++;
5403 0         0 }
5404 0         0 elsif ($char[$i] eq '\U') {
5405             $char[$i] = '@{[Elatin8::uc qq<';
5406             $left_e++;
5407 0         0 }
5408 0         0 elsif ($char[$i] eq '\L') {
5409             $char[$i] = '@{[Elatin8::lc qq<';
5410             $left_e++;
5411 0         0 }
5412 24         29 elsif ($char[$i] eq '\F') {
5413             $char[$i] = '@{[Elatin8::fc qq<';
5414             $left_e++;
5415 24         610 }
5416 0         0 elsif ($char[$i] eq '\Q') {
5417             $char[$i] = '@{[CORE::quotemeta qq<';
5418             $left_e++;
5419 0 50       0 }
5420 24         36 elsif ($char[$i] eq '\E') {
5421 24         34 if ($right_e < $left_e) {
5422             $char[$i] = '>]}';
5423             $right_e++;
5424 24         42 }
5425             else {
5426             $char[$i] = '';
5427             }
5428 0         0 }
5429 0 0       0 elsif ($char[$i] eq '\Q') {
5430 0         0 while (1) {
5431             if (++$i > $#char) {
5432 0 0       0 last;
5433 0         0 }
5434             if ($char[$i] eq '\E') {
5435             last;
5436             }
5437             }
5438             }
5439             elsif ($char[$i] eq '\E') {
5440             }
5441              
5442             # $0 --> $0
5443             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5444             }
5445             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5446             }
5447              
5448             # $$ --> $$
5449             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5450             }
5451              
5452             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5453 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5454             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5455             $char[$i] = e_capture($1);
5456 205         529 }
5457             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5458             $char[$i] = e_capture($1);
5459             }
5460              
5461 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5462             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5463             $char[$i] = e_capture($1.'->'.$2);
5464             }
5465              
5466 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5467             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5468             $char[$i] = e_capture($1.'->'.$2);
5469             }
5470              
5471 0         0 # $$foo
5472             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5473             $char[$i] = e_capture($1);
5474             }
5475              
5476 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
5477             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5478             $char[$i] = '@{[Elatin8::PREMATCH()]}';
5479             }
5480              
5481 44         131 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5482             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5483             $char[$i] = '@{[Elatin8::MATCH()]}';
5484             }
5485              
5486 45         134 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5487             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5488             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
5489             }
5490              
5491             # ${ foo } --> ${ foo }
5492             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5493             }
5494              
5495 33         100 # ${ ... }
5496             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5497             $char[$i] = e_capture($1);
5498             }
5499             }
5500 0 50       0  
5501 4110         9848 # return string
5502             if ($left_e > $right_e) {
5503 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5504             }
5505             return join '', $ope, $delimiter, @char, $end_delimiter;
5506             }
5507              
5508             #
5509             # escape qw string (qw//)
5510 4110     16 0 52722 #
5511             sub e_qw {
5512 16         96 my($ope,$delimiter,$end_delimiter,$string) = @_;
5513              
5514             $slash = 'div';
5515 16         128  
  16         232  
5516 483 50       815 # choice again delimiter
    0          
    0          
    0          
    0          
5517 16         96 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5518             if (not $octet{$end_delimiter}) {
5519             return join '', $ope, $delimiter, $string, $end_delimiter;
5520 16         142 }
5521             elsif (not $octet{')'}) {
5522             return join '', $ope, '(', $string, ')';
5523 0         0 }
5524             elsif (not $octet{'}'}) {
5525             return join '', $ope, '{', $string, '}';
5526 0         0 }
5527             elsif (not $octet{']'}) {
5528             return join '', $ope, '[', $string, ']';
5529 0         0 }
5530             elsif (not $octet{'>'}) {
5531             return join '', $ope, '<', $string, '>';
5532 0         0 }
5533 0 0       0 else {
5534 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5535             if (not $octet{$char}) {
5536             return join '', $ope, $char, $string, $char;
5537             }
5538             }
5539             }
5540 0         0  
5541 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5542 0         0 my @string = CORE::split(/\s+/, $string);
5543 0         0 for my $string (@string) {
5544 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5545 0         0 for my $octet (@octet) {
5546             if ($octet =~ /\A (['\\]) \z/oxms) {
5547             $octet = '\\' . $1;
5548 0         0 }
5549             }
5550 0         0 $string = join '', @octet;
  0         0  
5551             }
5552             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5553             }
5554              
5555             #
5556             # escape here document (<<"HEREDOC", <
5557 0     93 0 0 #
5558             sub e_heredoc {
5559 93         242 my($string) = @_;
5560              
5561 93         166 $slash = 'm//';
5562              
5563 93         352 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5564 93         161  
5565             my $left_e = 0;
5566             my $right_e = 0;
5567 93         128  
5568             # split regexp
5569             my @char = $string =~ /\G((?>
5570             [^\\\$] |
5571             \\x\{ (?>[0-9A-Fa-f]+) \} |
5572             \\o\{ (?>[0-7]+) \} |
5573             \\N\{ (?>[^0-9\}][^\}]*) \} |
5574             \\ $q_char |
5575             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5576             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5577             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5578             \$ (?>\s* [0-9]+) |
5579             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5580             \$ \$ (?![\w\{]) |
5581             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5582             $q_char
5583 93         8759 ))/oxmsg;
5584              
5585             for (my $i=0; $i <= $#char; $i++) {
5586 93 50 33     439  
    50 33        
    100          
    100          
    50          
5587 3177         9664 # "\L\u" --> "\u\L"
5588             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5589             @char[$i,$i+1] = @char[$i+1,$i];
5590             }
5591              
5592 0         0 # "\U\l" --> "\l\U"
5593             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5594             @char[$i,$i+1] = @char[$i+1,$i];
5595             }
5596              
5597 0         0 # octal escape sequence
5598             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5599             $char[$i] = Elatin8::octchr($1);
5600             }
5601              
5602 1         4 # hexadecimal escape sequence
5603             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5604             $char[$i] = Elatin8::hexchr($1);
5605             }
5606              
5607 1         3 # \N{CHARNAME} --> N{CHARNAME}
5608             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5609             $char[$i] = $1;
5610 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          
5611              
5612             if (0) {
5613             }
5614 3177         36662  
5615 0 0       0 # \u \l \U \L \F \Q \E
5616 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5617             if ($right_e < $left_e) {
5618             $char[$i] = '\\' . $char[$i];
5619             }
5620 0         0 }
5621 0         0 elsif ($char[$i] eq '\u') {
5622             $char[$i] = '@{[Elatin8::ucfirst qq<';
5623             $left_e++;
5624 0         0 }
5625 0         0 elsif ($char[$i] eq '\l') {
5626             $char[$i] = '@{[Elatin8::lcfirst qq<';
5627             $left_e++;
5628 0         0 }
5629 0         0 elsif ($char[$i] eq '\U') {
5630             $char[$i] = '@{[Elatin8::uc qq<';
5631             $left_e++;
5632 0         0 }
5633 0         0 elsif ($char[$i] eq '\L') {
5634             $char[$i] = '@{[Elatin8::lc qq<';
5635             $left_e++;
5636 0         0 }
5637 0         0 elsif ($char[$i] eq '\F') {
5638             $char[$i] = '@{[Elatin8::fc qq<';
5639             $left_e++;
5640 0         0 }
5641 0         0 elsif ($char[$i] eq '\Q') {
5642             $char[$i] = '@{[CORE::quotemeta qq<';
5643             $left_e++;
5644 0 0       0 }
5645 0         0 elsif ($char[$i] eq '\E') {
5646 0         0 if ($right_e < $left_e) {
5647             $char[$i] = '>]}';
5648             $right_e++;
5649 0         0 }
5650             else {
5651             $char[$i] = '';
5652             }
5653 0         0 }
5654 0 0       0 elsif ($char[$i] eq '\Q') {
5655 0         0 while (1) {
5656             if (++$i > $#char) {
5657 0 0       0 last;
5658 0         0 }
5659             if ($char[$i] eq '\E') {
5660             last;
5661             }
5662             }
5663             }
5664             elsif ($char[$i] eq '\E') {
5665             }
5666              
5667             # $0 --> $0
5668             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5669             }
5670             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5671             }
5672              
5673             # $$ --> $$
5674             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5675             }
5676              
5677             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5678 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5679             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5680             $char[$i] = e_capture($1);
5681 0         0 }
5682             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5683             $char[$i] = e_capture($1);
5684             }
5685              
5686 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5687             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5688             $char[$i] = e_capture($1.'->'.$2);
5689             }
5690              
5691 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5692             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5693             $char[$i] = e_capture($1.'->'.$2);
5694             }
5695              
5696 0         0 # $$foo
5697             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5698             $char[$i] = e_capture($1);
5699             }
5700              
5701 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
5702             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5703             $char[$i] = '@{[Elatin8::PREMATCH()]}';
5704             }
5705              
5706 8         60 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5707             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5708             $char[$i] = '@{[Elatin8::MATCH()]}';
5709             }
5710              
5711 8         53 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5712             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5713             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
5714             }
5715              
5716             # ${ foo } --> ${ foo }
5717             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5718             }
5719              
5720 6         34 # ${ ... }
5721             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5722             $char[$i] = e_capture($1);
5723             }
5724             }
5725 0 50       0  
5726 93         217 # return string
5727             if ($left_e > $right_e) {
5728 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5729             }
5730             return join '', @char;
5731             }
5732              
5733             #
5734             # escape regexp (m//, qr//)
5735 93     652 0 713 #
5736 652   100     3102 sub e_qr {
5737             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5738 652         2704 $modifier ||= '';
5739 652 50       1254  
5740 652         2727 $modifier =~ tr/p//d;
5741 0         0 if ($modifier =~ /([adlu])/oxms) {
5742 0 0       0 my $line = 0;
5743 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5744 0         0 if ($filename ne __FILE__) {
5745             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5746             last;
5747 0         0 }
5748             }
5749             die qq{Unsupported modifier "$1" used at line $line.\n};
5750 0         0 }
5751              
5752             $slash = 'div';
5753 652 100       1376  
    100          
5754 652         2168 # literal null string pattern
5755 8         11 if ($string eq '') {
5756 8         10 $modifier =~ tr/bB//d;
5757             $modifier =~ tr/i//d;
5758             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5759             }
5760              
5761             # /b /B modifier
5762             elsif ($modifier =~ tr/bB//d) {
5763 8 50       38  
5764 2         9 # choice again delimiter
5765 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5766 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5767 0         0 my %octet = map {$_ => 1} @char;
5768 0         0 if (not $octet{')'}) {
5769             $delimiter = '(';
5770             $end_delimiter = ')';
5771 0         0 }
5772 0         0 elsif (not $octet{'}'}) {
5773             $delimiter = '{';
5774             $end_delimiter = '}';
5775 0         0 }
5776 0         0 elsif (not $octet{']'}) {
5777             $delimiter = '[';
5778             $end_delimiter = ']';
5779 0         0 }
5780 0         0 elsif (not $octet{'>'}) {
5781             $delimiter = '<';
5782             $end_delimiter = '>';
5783 0         0 }
5784 0 0       0 else {
5785 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5786 0         0 if (not $octet{$char}) {
5787 0         0 $delimiter = $char;
5788             $end_delimiter = $char;
5789             last;
5790             }
5791             }
5792             }
5793 0 50 33     0 }
5794 2         27  
5795             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5796             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5797 0         0 }
5798             else {
5799             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5800             }
5801 2 100       13 }
5802 642         1752  
5803             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5804             my $metachar = qr/[\@\\|[\]{^]/oxms;
5805 642         2380  
5806             # split regexp
5807             my @char = $string =~ /\G((?>
5808             [^\\\$\@\[\(] |
5809             \\x (?>[0-9A-Fa-f]{1,2}) |
5810             \\ (?>[0-7]{2,3}) |
5811             \\c [\x40-\x5F] |
5812             \\x\{ (?>[0-9A-Fa-f]+) \} |
5813             \\o\{ (?>[0-7]+) \} |
5814             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5815             \\ $q_char |
5816             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5817             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5818             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5819             [\$\@] $qq_variable |
5820             \$ (?>\s* [0-9]+) |
5821             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5822             \$ \$ (?![\w\{]) |
5823             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5824             \[\^ |
5825             \[\: (?>[a-z]+) :\] |
5826             \[\:\^ (?>[a-z]+) :\] |
5827             \(\? |
5828             $q_char
5829             ))/oxmsg;
5830 642 50       86229  
5831 642         4786 # choice again delimiter
  0         0  
5832 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5833 0         0 my %octet = map {$_ => 1} @char;
5834 0         0 if (not $octet{')'}) {
5835             $delimiter = '(';
5836             $end_delimiter = ')';
5837 0         0 }
5838 0         0 elsif (not $octet{'}'}) {
5839             $delimiter = '{';
5840             $end_delimiter = '}';
5841 0         0 }
5842 0         0 elsif (not $octet{']'}) {
5843             $delimiter = '[';
5844             $end_delimiter = ']';
5845 0         0 }
5846 0         0 elsif (not $octet{'>'}) {
5847             $delimiter = '<';
5848             $end_delimiter = '>';
5849 0         0 }
5850 0 0       0 else {
5851 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5852 0         0 if (not $octet{$char}) {
5853 0         0 $delimiter = $char;
5854             $end_delimiter = $char;
5855             last;
5856             }
5857             }
5858             }
5859 0         0 }
5860 642         1046  
5861 642         977 my $left_e = 0;
5862             my $right_e = 0;
5863             for (my $i=0; $i <= $#char; $i++) {
5864 642 50 66     2817  
    50 66        
    100          
    100          
    100          
    100          
5865 1872         10103 # "\L\u" --> "\u\L"
5866             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5867             @char[$i,$i+1] = @char[$i+1,$i];
5868             }
5869              
5870 0         0 # "\U\l" --> "\l\U"
5871             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5872             @char[$i,$i+1] = @char[$i+1,$i];
5873             }
5874              
5875 0         0 # octal escape sequence
5876             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5877             $char[$i] = Elatin8::octchr($1);
5878             }
5879              
5880 1         4 # hexadecimal escape sequence
5881             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5882             $char[$i] = Elatin8::hexchr($1);
5883             }
5884              
5885             # \b{...} --> b\{...}
5886             # \B{...} --> B\{...}
5887             # \N{CHARNAME} --> N\{CHARNAME}
5888             # \p{PROPERTY} --> p\{PROPERTY}
5889 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5890             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5891             $char[$i] = $1 . '\\' . $2;
5892             }
5893              
5894 6         21 # \p, \P, \X --> p, P, X
5895             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5896             $char[$i] = $1;
5897 4 100 100     11 }
    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          
5898              
5899             if (0) {
5900             }
5901 1872         6302  
5902 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5903 6         83 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5904             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)) {
5905             $char[$i] .= join '', splice @char, $i+1, 3;
5906 0         0 }
5907             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)) {
5908             $char[$i] .= join '', splice @char, $i+1, 2;
5909 0         0 }
5910             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)) {
5911             $char[$i] .= join '', splice @char, $i+1, 1;
5912             }
5913             }
5914              
5915 0         0 # open character class [...]
5916             elsif ($char[$i] eq '[') {
5917             my $left = $i;
5918              
5919             # [] make die "Unmatched [] in regexp ...\n"
5920 328 100       501 # (and so on)
5921 328         1893  
5922             if ($char[$i+1] eq ']') {
5923             $i++;
5924 3         7 }
5925 328 50       427  
5926 1379         2229 while (1) {
5927             if (++$i > $#char) {
5928 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5929 1379         2133 }
5930             if ($char[$i] eq ']') {
5931             my $right = $i;
5932 328 100       407  
5933 328         2340 # [...]
  30         75  
5934             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5935             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5936 90         158 }
5937             else {
5938             splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
5939 298         1429 }
5940 328         619  
5941             $i = $left;
5942             last;
5943             }
5944             }
5945             }
5946              
5947 328         938 # open character class [^...]
5948             elsif ($char[$i] eq '[^') {
5949             my $left = $i;
5950              
5951             # [^] make die "Unmatched [] in regexp ...\n"
5952 74 100       94 # (and so on)
5953 74         160  
5954             if ($char[$i+1] eq ']') {
5955             $i++;
5956 4         6 }
5957 74 50       88  
5958 272         397 while (1) {
5959             if (++$i > $#char) {
5960 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5961 272         464 }
5962             if ($char[$i] eq ']') {
5963             my $right = $i;
5964 74 100       94  
5965 74         564 # [^...]
  30         71  
5966             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5967             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5968 90         132 }
5969             else {
5970             splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5971 44         178 }
5972 74         134  
5973             $i = $left;
5974             last;
5975             }
5976             }
5977             }
5978              
5979 74         190 # rewrite character class or escape character
5980             elsif (my $char = character_class($char[$i],$modifier)) {
5981             $char[$i] = $char;
5982             }
5983              
5984 139 50       419 # /i modifier
5985 20         36 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
5986             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
5987             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
5988 20         28 }
5989             else {
5990             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
5991             }
5992             }
5993              
5994 0 50       0 # \u \l \U \L \F \Q \E
5995 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5996             if ($right_e < $left_e) {
5997             $char[$i] = '\\' . $char[$i];
5998             }
5999 0         0 }
6000 0         0 elsif ($char[$i] eq '\u') {
6001             $char[$i] = '@{[Elatin8::ucfirst qq<';
6002             $left_e++;
6003 0         0 }
6004 0         0 elsif ($char[$i] eq '\l') {
6005             $char[$i] = '@{[Elatin8::lcfirst qq<';
6006             $left_e++;
6007 0         0 }
6008 1         2 elsif ($char[$i] eq '\U') {
6009             $char[$i] = '@{[Elatin8::uc qq<';
6010             $left_e++;
6011 1         3 }
6012 1         3 elsif ($char[$i] eq '\L') {
6013             $char[$i] = '@{[Elatin8::lc qq<';
6014             $left_e++;
6015 1         2 }
6016 18         33 elsif ($char[$i] eq '\F') {
6017             $char[$i] = '@{[Elatin8::fc qq<';
6018             $left_e++;
6019 18         39 }
6020 1         3 elsif ($char[$i] eq '\Q') {
6021             $char[$i] = '@{[CORE::quotemeta qq<';
6022             $left_e++;
6023 1 50       2 }
6024 21         45 elsif ($char[$i] eq '\E') {
6025 21         52 if ($right_e < $left_e) {
6026             $char[$i] = '>]}';
6027             $right_e++;
6028 21         50 }
6029             else {
6030             $char[$i] = '';
6031             }
6032 0         0 }
6033 0 0       0 elsif ($char[$i] eq '\Q') {
6034 0         0 while (1) {
6035             if (++$i > $#char) {
6036 0 0       0 last;
6037 0         0 }
6038             if ($char[$i] eq '\E') {
6039             last;
6040             }
6041             }
6042             }
6043             elsif ($char[$i] eq '\E') {
6044             }
6045              
6046 0 0       0 # $0 --> $0
6047 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6048             if ($ignorecase) {
6049             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6050             }
6051 0 0       0 }
6052 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6053             if ($ignorecase) {
6054             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6055             }
6056             }
6057              
6058             # $$ --> $$
6059             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6060             }
6061              
6062             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6063 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6064 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6065 0         0 $char[$i] = e_capture($1);
6066             if ($ignorecase) {
6067             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6068             }
6069 0         0 }
6070 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6071 0         0 $char[$i] = e_capture($1);
6072             if ($ignorecase) {
6073             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6074             }
6075             }
6076              
6077 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6078 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) {
6079 0         0 $char[$i] = e_capture($1.'->'.$2);
6080             if ($ignorecase) {
6081             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6082             }
6083             }
6084              
6085 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6086 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) {
6087 0         0 $char[$i] = e_capture($1.'->'.$2);
6088             if ($ignorecase) {
6089             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6090             }
6091             }
6092              
6093 0         0 # $$foo
6094 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6095 0         0 $char[$i] = e_capture($1);
6096             if ($ignorecase) {
6097             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6098             }
6099             }
6100              
6101 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
6102 8         10793 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6103             if ($ignorecase) {
6104             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
6105 0         0 }
6106             else {
6107             $char[$i] = '@{[Elatin8::PREMATCH()]}';
6108             }
6109             }
6110              
6111 8 50       34 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
6112 8         22 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6113             if ($ignorecase) {
6114             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
6115 0         0 }
6116             else {
6117             $char[$i] = '@{[Elatin8::MATCH()]}';
6118             }
6119             }
6120              
6121 8 50       24 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
6122 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6123             if ($ignorecase) {
6124             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
6125 0         0 }
6126             else {
6127             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
6128             }
6129             }
6130              
6131 6 0       201 # ${ foo }
6132 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) {
6133             if ($ignorecase) {
6134             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6135             }
6136             }
6137              
6138 0         0 # ${ ... }
6139 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6140 0         0 $char[$i] = e_capture($1);
6141             if ($ignorecase) {
6142             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6143             }
6144             }
6145              
6146 0         0 # $scalar or @array
6147 21 100       47 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6148 21         140 $char[$i] = e_string($char[$i]);
6149             if ($ignorecase) {
6150             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6151             }
6152             }
6153              
6154 11 100 33     35 # quote character before ? + * {
    50          
6155             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6156             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6157 138         1187 }
6158 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6159 0         0 my $char = $char[$i-1];
6160             if ($char[$i] eq '{') {
6161             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6162 0         0 }
6163             else {
6164             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6165             }
6166 0         0 }
6167             else {
6168             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6169             }
6170             }
6171             }
6172 127         1620  
6173 642 50       1527 # make regexp string
6174 642 0 0     2742 $modifier =~ tr/i//d;
6175 0         0 if ($left_e > $right_e) {
6176             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6177             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6178 0         0 }
6179             else {
6180             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6181 0 50 33     0 }
6182 642         3820 }
6183             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6184             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6185 0         0 }
6186             else {
6187             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6188             }
6189             }
6190              
6191             #
6192             # double quote stuff
6193 642     180 0 5520 #
6194             sub qq_stuff {
6195             my($delimiter,$end_delimiter,$stuff) = @_;
6196 180 100       366  
6197 180         364 # scalar variable or array variable
6198             if ($stuff =~ /\A [\$\@] /oxms) {
6199             return $stuff;
6200             }
6201 100         393  
  80         192  
6202 80         228 # quote by delimiter
6203 80 50       198 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6204 80 50       133 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6205 80 50       123 next if $char eq $delimiter;
6206 80         191 next if $char eq $end_delimiter;
6207             if (not $octet{$char}) {
6208             return join '', 'qq', $char, $stuff, $char;
6209 80         359 }
6210             }
6211             return join '', 'qq', '<', $stuff, '>';
6212             }
6213              
6214             #
6215             # escape regexp (m'', qr'', and m''b, qr''b)
6216 0     10 0 0 #
6217 10   50     39 sub e_qr_q {
6218             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6219 10         42 $modifier ||= '';
6220 10 50       14  
6221 10         22 $modifier =~ tr/p//d;
6222 0         0 if ($modifier =~ /([adlu])/oxms) {
6223 0 0       0 my $line = 0;
6224 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6225 0         0 if ($filename ne __FILE__) {
6226             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6227             last;
6228 0         0 }
6229             }
6230             die qq{Unsupported modifier "$1" used at line $line.\n};
6231 0         0 }
6232              
6233             $slash = 'div';
6234 10 100       14  
    50          
6235 10         23 # literal null string pattern
6236 8         9 if ($string eq '') {
6237 8         9 $modifier =~ tr/bB//d;
6238             $modifier =~ tr/i//d;
6239             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6240             }
6241              
6242 8         38 # with /b /B modifier
6243             elsif ($modifier =~ tr/bB//d) {
6244             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6245             }
6246              
6247 0         0 # without /b /B modifier
6248             else {
6249             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6250             }
6251             }
6252              
6253             #
6254             # escape regexp (m'', qr'')
6255 2     2 0 7 #
6256             sub e_qr_qt {
6257 2 50       5 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6258              
6259             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6260 2         5  
6261             # split regexp
6262             my @char = $string =~ /\G((?>
6263             [^\\\[\$\@\/] |
6264             [\x00-\xFF] |
6265             \[\^ |
6266             \[\: (?>[a-z]+) \:\] |
6267             \[\:\^ (?>[a-z]+) \:\] |
6268             [\$\@\/] |
6269             \\ (?:$q_char) |
6270             (?:$q_char)
6271             ))/oxmsg;
6272 2         61  
6273 2 50 33     9 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6274             for (my $i=0; $i <= $#char; $i++) {
6275             if (0) {
6276             }
6277 2         17  
6278 0         0 # open character class [...]
6279 0 0       0 elsif ($char[$i] eq '[') {
6280 0         0 my $left = $i;
6281             if ($char[$i+1] eq ']') {
6282 0         0 $i++;
6283 0 0       0 }
6284 0         0 while (1) {
6285             if (++$i > $#char) {
6286 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6287 0         0 }
6288             if ($char[$i] eq ']') {
6289             my $right = $i;
6290 0         0  
6291             # [...]
6292 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6293 0         0  
6294             $i = $left;
6295             last;
6296             }
6297             }
6298             }
6299              
6300 0         0 # open character class [^...]
6301 0 0       0 elsif ($char[$i] eq '[^') {
6302 0         0 my $left = $i;
6303             if ($char[$i+1] eq ']') {
6304 0         0 $i++;
6305 0 0       0 }
6306 0         0 while (1) {
6307             if (++$i > $#char) {
6308 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6309 0         0 }
6310             if ($char[$i] eq ']') {
6311             my $right = $i;
6312 0         0  
6313             # [^...]
6314 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6315 0         0  
6316             $i = $left;
6317             last;
6318             }
6319             }
6320             }
6321              
6322 0         0 # escape $ @ / and \
6323             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6324             $char[$i] = '\\' . $char[$i];
6325             }
6326              
6327 0         0 # rewrite character class or escape character
6328             elsif (my $char = character_class($char[$i],$modifier)) {
6329             $char[$i] = $char;
6330             }
6331              
6332 0 0       0 # /i modifier
6333 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6334             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6335             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6336 0         0 }
6337             else {
6338             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6339             }
6340             }
6341              
6342 0 0       0 # quote character before ? + * {
6343             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6344             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6345 0         0 }
6346             else {
6347             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6348             }
6349             }
6350 0         0 }
6351 2         4  
6352             $delimiter = '/';
6353 2         3 $end_delimiter = '/';
6354 2         4  
6355             $modifier =~ tr/i//d;
6356             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6357             }
6358              
6359             #
6360             # escape regexp (m''b, qr''b)
6361 2     0 0 13 #
6362             sub e_qr_qb {
6363             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6364 0         0  
6365             # split regexp
6366             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6367 0         0  
6368 0 0       0 # unescape character
    0          
6369             for (my $i=0; $i <= $#char; $i++) {
6370             if (0) {
6371             }
6372 0         0  
6373             # remain \\
6374             elsif ($char[$i] eq '\\\\') {
6375             }
6376              
6377 0         0 # escape $ @ / and \
6378             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6379             $char[$i] = '\\' . $char[$i];
6380             }
6381 0         0 }
6382 0         0  
6383 0         0 $delimiter = '/';
6384             $end_delimiter = '/';
6385             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6386             }
6387              
6388             #
6389             # escape regexp (s/here//)
6390 0     76 0 0 #
6391 76   100     230 sub e_s1 {
6392             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6393 76         333 $modifier ||= '';
6394 76 50       235  
6395 76         219 $modifier =~ tr/p//d;
6396 0         0 if ($modifier =~ /([adlu])/oxms) {
6397 0 0       0 my $line = 0;
6398 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6399 0         0 if ($filename ne __FILE__) {
6400             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6401             last;
6402 0         0 }
6403             }
6404             die qq{Unsupported modifier "$1" used at line $line.\n};
6405 0         0 }
6406              
6407             $slash = 'div';
6408 76 100       140  
    50          
6409 76         397 # literal null string pattern
6410 8         11 if ($string eq '') {
6411 8         7 $modifier =~ tr/bB//d;
6412             $modifier =~ tr/i//d;
6413             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6414             }
6415              
6416             # /b /B modifier
6417             elsif ($modifier =~ tr/bB//d) {
6418 8 0       58  
6419 0         0 # choice again delimiter
6420 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6421 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6422 0         0 my %octet = map {$_ => 1} @char;
6423 0         0 if (not $octet{')'}) {
6424             $delimiter = '(';
6425             $end_delimiter = ')';
6426 0         0 }
6427 0         0 elsif (not $octet{'}'}) {
6428             $delimiter = '{';
6429             $end_delimiter = '}';
6430 0         0 }
6431 0         0 elsif (not $octet{']'}) {
6432             $delimiter = '[';
6433             $end_delimiter = ']';
6434 0         0 }
6435 0         0 elsif (not $octet{'>'}) {
6436             $delimiter = '<';
6437             $end_delimiter = '>';
6438 0         0 }
6439 0 0       0 else {
6440 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6441 0         0 if (not $octet{$char}) {
6442 0         0 $delimiter = $char;
6443             $end_delimiter = $char;
6444             last;
6445             }
6446             }
6447             }
6448 0         0 }
6449 0         0  
6450             my $prematch = '';
6451             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6452 0 100       0 }
6453 68         202  
6454             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6455             my $metachar = qr/[\@\\|[\]{^]/oxms;
6456 68         263  
6457             # split regexp
6458             my @char = $string =~ /\G((?>
6459             [^\\\$\@\[\(] |
6460             \\ (?>[1-9][0-9]*) |
6461             \\g (?>\s*) (?>[1-9][0-9]*) |
6462             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6463             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6464             \\x (?>[0-9A-Fa-f]{1,2}) |
6465             \\ (?>[0-7]{2,3}) |
6466             \\c [\x40-\x5F] |
6467             \\x\{ (?>[0-9A-Fa-f]+) \} |
6468             \\o\{ (?>[0-7]+) \} |
6469             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6470             \\ $q_char |
6471             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6472             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6473             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6474             [\$\@] $qq_variable |
6475             \$ (?>\s* [0-9]+) |
6476             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6477             \$ \$ (?![\w\{]) |
6478             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6479             \[\^ |
6480             \[\: (?>[a-z]+) :\] |
6481             \[\:\^ (?>[a-z]+) :\] |
6482             \(\? |
6483             $q_char
6484             ))/oxmsg;
6485 68 50       21538  
6486 68         515 # choice again delimiter
  0         0  
6487 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6488 0         0 my %octet = map {$_ => 1} @char;
6489 0         0 if (not $octet{')'}) {
6490             $delimiter = '(';
6491             $end_delimiter = ')';
6492 0         0 }
6493 0         0 elsif (not $octet{'}'}) {
6494             $delimiter = '{';
6495             $end_delimiter = '}';
6496 0         0 }
6497 0         0 elsif (not $octet{']'}) {
6498             $delimiter = '[';
6499             $end_delimiter = ']';
6500 0         0 }
6501 0         0 elsif (not $octet{'>'}) {
6502             $delimiter = '<';
6503             $end_delimiter = '>';
6504 0         0 }
6505 0 0       0 else {
6506 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6507 0         0 if (not $octet{$char}) {
6508 0         0 $delimiter = $char;
6509             $end_delimiter = $char;
6510             last;
6511             }
6512             }
6513             }
6514             }
6515 0         0  
  68         141  
6516             # count '('
6517 253         451 my $parens = grep { $_ eq '(' } @char;
6518 68         106  
6519 68         160 my $left_e = 0;
6520             my $right_e = 0;
6521             for (my $i=0; $i <= $#char; $i++) {
6522 68 50 33     221  
    50 33        
    100          
    100          
    50          
    50          
6523 195         1195 # "\L\u" --> "\u\L"
6524             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6525             @char[$i,$i+1] = @char[$i+1,$i];
6526             }
6527              
6528 0         0 # "\U\l" --> "\l\U"
6529             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6530             @char[$i,$i+1] = @char[$i+1,$i];
6531             }
6532              
6533 0         0 # octal escape sequence
6534             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6535             $char[$i] = Elatin8::octchr($1);
6536             }
6537              
6538 1         3 # hexadecimal escape sequence
6539             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6540             $char[$i] = Elatin8::hexchr($1);
6541             }
6542              
6543             # \b{...} --> b\{...}
6544             # \B{...} --> B\{...}
6545             # \N{CHARNAME} --> N\{CHARNAME}
6546             # \p{PROPERTY} --> p\{PROPERTY}
6547 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6548             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6549             $char[$i] = $1 . '\\' . $2;
6550             }
6551              
6552 0         0 # \p, \P, \X --> p, P, X
6553             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6554             $char[$i] = $1;
6555 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          
6556              
6557             if (0) {
6558             }
6559 195         720  
6560 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6561 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6562             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)) {
6563             $char[$i] .= join '', splice @char, $i+1, 3;
6564 0         0 }
6565             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)) {
6566             $char[$i] .= join '', splice @char, $i+1, 2;
6567 0         0 }
6568             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)) {
6569             $char[$i] .= join '', splice @char, $i+1, 1;
6570             }
6571             }
6572              
6573 0         0 # open character class [...]
6574 13 50       72 elsif ($char[$i] eq '[') {
6575 13         55 my $left = $i;
6576             if ($char[$i+1] eq ']') {
6577 0         0 $i++;
6578 13 50       22 }
6579 58         87 while (1) {
6580             if (++$i > $#char) {
6581 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6582 58         118 }
6583             if ($char[$i] eq ']') {
6584             my $right = $i;
6585 13 50       22  
6586 13         85 # [...]
  0         0  
6587             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6588             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6589 0         0 }
6590             else {
6591             splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6592 13         54 }
6593 13         23  
6594             $i = $left;
6595             last;
6596             }
6597             }
6598             }
6599              
6600 13         33 # open character class [^...]
6601 0 0       0 elsif ($char[$i] eq '[^') {
6602 0         0 my $left = $i;
6603             if ($char[$i+1] eq ']') {
6604 0         0 $i++;
6605 0 0       0 }
6606 0         0 while (1) {
6607             if (++$i > $#char) {
6608 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6609 0         0 }
6610             if ($char[$i] eq ']') {
6611             my $right = $i;
6612 0 0       0  
6613 0         0 # [^...]
  0         0  
6614             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6615             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6616 0         0 }
6617             else {
6618             splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6619 0         0 }
6620 0         0  
6621             $i = $left;
6622             last;
6623             }
6624             }
6625             }
6626              
6627 0         0 # rewrite character class or escape character
6628             elsif (my $char = character_class($char[$i],$modifier)) {
6629             $char[$i] = $char;
6630             }
6631              
6632 7 50       16 # /i modifier
6633 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6634             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6635             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6636 3         12 }
6637             else {
6638             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6639             }
6640             }
6641              
6642 0 0       0 # \u \l \U \L \F \Q \E
6643 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6644             if ($right_e < $left_e) {
6645             $char[$i] = '\\' . $char[$i];
6646             }
6647 0         0 }
6648 0         0 elsif ($char[$i] eq '\u') {
6649             $char[$i] = '@{[Elatin8::ucfirst qq<';
6650             $left_e++;
6651 0         0 }
6652 0         0 elsif ($char[$i] eq '\l') {
6653             $char[$i] = '@{[Elatin8::lcfirst qq<';
6654             $left_e++;
6655 0         0 }
6656 0         0 elsif ($char[$i] eq '\U') {
6657             $char[$i] = '@{[Elatin8::uc qq<';
6658             $left_e++;
6659 0         0 }
6660 0         0 elsif ($char[$i] eq '\L') {
6661             $char[$i] = '@{[Elatin8::lc qq<';
6662             $left_e++;
6663 0         0 }
6664 0         0 elsif ($char[$i] eq '\F') {
6665             $char[$i] = '@{[Elatin8::fc qq<';
6666             $left_e++;
6667 0         0 }
6668 0         0 elsif ($char[$i] eq '\Q') {
6669             $char[$i] = '@{[CORE::quotemeta qq<';
6670             $left_e++;
6671 0 0       0 }
6672 0         0 elsif ($char[$i] eq '\E') {
6673 0         0 if ($right_e < $left_e) {
6674             $char[$i] = '>]}';
6675             $right_e++;
6676 0         0 }
6677             else {
6678             $char[$i] = '';
6679             }
6680 0         0 }
6681 0 0       0 elsif ($char[$i] eq '\Q') {
6682 0         0 while (1) {
6683             if (++$i > $#char) {
6684 0 0       0 last;
6685 0         0 }
6686             if ($char[$i] eq '\E') {
6687             last;
6688             }
6689             }
6690             }
6691             elsif ($char[$i] eq '\E') {
6692             }
6693              
6694             # \0 --> \0
6695             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6696             }
6697              
6698             # \g{N}, \g{-N}
6699              
6700             # P.108 Using Simple Patterns
6701             # in Chapter 7: In the World of Regular Expressions
6702             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6703              
6704             # P.221 Capturing
6705             # in Chapter 5: Pattern Matching
6706             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6707              
6708             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6709             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6710             }
6711              
6712             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6713             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6714             }
6715              
6716             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6717             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6718             }
6719              
6720             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6721             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6722             }
6723              
6724 0 0       0 # $0 --> $0
6725 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6726             if ($ignorecase) {
6727             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6728             }
6729 0 0       0 }
6730 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6731             if ($ignorecase) {
6732             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6733             }
6734             }
6735              
6736             # $$ --> $$
6737             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6738             }
6739              
6740             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6741 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6742 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6743 0         0 $char[$i] = e_capture($1);
6744             if ($ignorecase) {
6745             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6746             }
6747 0         0 }
6748 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6749 0         0 $char[$i] = e_capture($1);
6750             if ($ignorecase) {
6751             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6752             }
6753             }
6754              
6755 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6756 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) {
6757 0         0 $char[$i] = e_capture($1.'->'.$2);
6758             if ($ignorecase) {
6759             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6760             }
6761             }
6762              
6763 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6764 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) {
6765 0         0 $char[$i] = e_capture($1.'->'.$2);
6766             if ($ignorecase) {
6767             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6768             }
6769             }
6770              
6771 0         0 # $$foo
6772 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6773 0         0 $char[$i] = e_capture($1);
6774             if ($ignorecase) {
6775             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6776             }
6777             }
6778              
6779 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
6780 4         16 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6781             if ($ignorecase) {
6782             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
6783 0         0 }
6784             else {
6785             $char[$i] = '@{[Elatin8::PREMATCH()]}';
6786             }
6787             }
6788              
6789 4 50       15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
6790 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6791             if ($ignorecase) {
6792             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
6793 0         0 }
6794             else {
6795             $char[$i] = '@{[Elatin8::MATCH()]}';
6796             }
6797             }
6798              
6799 4 50       22 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
6800 3         11 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6801             if ($ignorecase) {
6802             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
6803 0         0 }
6804             else {
6805             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
6806             }
6807             }
6808              
6809 3 0       11 # ${ foo }
6810 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) {
6811             if ($ignorecase) {
6812             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6813             }
6814             }
6815              
6816 0         0 # ${ ... }
6817 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6818 0         0 $char[$i] = e_capture($1);
6819             if ($ignorecase) {
6820             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6821             }
6822             }
6823              
6824 0         0 # $scalar or @array
6825 4 50       24 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6826 4         20 $char[$i] = e_string($char[$i]);
6827             if ($ignorecase) {
6828             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6829             }
6830             }
6831              
6832 0 50       0 # quote character before ? + * {
6833             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6834             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6835 13         78 }
6836             else {
6837             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6838             }
6839             }
6840             }
6841 13         63  
6842 68         183 # make regexp string
6843 68 50       200 my $prematch = '';
6844 68         222 $modifier =~ tr/i//d;
6845             if ($left_e > $right_e) {
6846 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6847             }
6848             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6849             }
6850              
6851             #
6852             # escape regexp (s'here'' or s'here''b)
6853 68     21 0 854 #
6854 21   100     46 sub e_s1_q {
6855             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6856 21         64 $modifier ||= '';
6857 21 50       28  
6858 21         44 $modifier =~ tr/p//d;
6859 0         0 if ($modifier =~ /([adlu])/oxms) {
6860 0 0       0 my $line = 0;
6861 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6862 0         0 if ($filename ne __FILE__) {
6863             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6864             last;
6865 0         0 }
6866             }
6867             die qq{Unsupported modifier "$1" used at line $line.\n};
6868 0         0 }
6869              
6870             $slash = 'div';
6871 21 100       46  
    50          
6872 21         53 # literal null string pattern
6873 8         16 if ($string eq '') {
6874 8         9 $modifier =~ tr/bB//d;
6875             $modifier =~ tr/i//d;
6876             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6877             }
6878              
6879 8         118 # with /b /B modifier
6880             elsif ($modifier =~ tr/bB//d) {
6881             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6882             }
6883              
6884 0         0 # without /b /B modifier
6885             else {
6886             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6887             }
6888             }
6889              
6890             #
6891             # escape regexp (s'here'')
6892 13     13 0 30 #
6893             sub e_s1_qt {
6894 13 50       28 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6895              
6896             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6897 13         28  
6898             # split regexp
6899             my @char = $string =~ /\G((?>
6900             [^\\\[\$\@\/] |
6901             [\x00-\xFF] |
6902             \[\^ |
6903             \[\: (?>[a-z]+) \:\] |
6904             \[\:\^ (?>[a-z]+) \:\] |
6905             [\$\@\/] |
6906             \\ (?:$q_char) |
6907             (?:$q_char)
6908             ))/oxmsg;
6909 13         294  
6910 13 50 33     47 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6911             for (my $i=0; $i <= $#char; $i++) {
6912             if (0) {
6913             }
6914 25         102  
6915 0         0 # open character class [...]
6916 0 0       0 elsif ($char[$i] eq '[') {
6917 0         0 my $left = $i;
6918             if ($char[$i+1] eq ']') {
6919 0         0 $i++;
6920 0 0       0 }
6921 0         0 while (1) {
6922             if (++$i > $#char) {
6923 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6924 0         0 }
6925             if ($char[$i] eq ']') {
6926             my $right = $i;
6927 0         0  
6928             # [...]
6929 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6930 0         0  
6931             $i = $left;
6932             last;
6933             }
6934             }
6935             }
6936              
6937 0         0 # open character class [^...]
6938 0 0       0 elsif ($char[$i] eq '[^') {
6939 0         0 my $left = $i;
6940             if ($char[$i+1] eq ']') {
6941 0         0 $i++;
6942 0 0       0 }
6943 0         0 while (1) {
6944             if (++$i > $#char) {
6945 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6946 0         0 }
6947             if ($char[$i] eq ']') {
6948             my $right = $i;
6949 0         0  
6950             # [^...]
6951 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6952 0         0  
6953             $i = $left;
6954             last;
6955             }
6956             }
6957             }
6958              
6959 0         0 # escape $ @ / and \
6960             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6961             $char[$i] = '\\' . $char[$i];
6962             }
6963              
6964 0         0 # rewrite character class or escape character
6965             elsif (my $char = character_class($char[$i],$modifier)) {
6966             $char[$i] = $char;
6967             }
6968              
6969 6 0       13 # /i modifier
6970 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6971             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6972             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6973 0         0 }
6974             else {
6975             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6976             }
6977             }
6978              
6979 0 0       0 # quote character before ? + * {
6980             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6981             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6982 0         0 }
6983             else {
6984             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6985             }
6986             }
6987 0         0 }
6988 13         24  
6989 13         19 $modifier =~ tr/i//d;
6990 13         17 $delimiter = '/';
6991 13         18 $end_delimiter = '/';
6992             my $prematch = '';
6993             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6994             }
6995              
6996             #
6997             # escape regexp (s'here''b)
6998 13     0 0 93 #
6999             sub e_s1_qb {
7000             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7001 0         0  
7002             # split regexp
7003             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
7004 0         0  
7005 0 0       0 # unescape character
    0          
7006             for (my $i=0; $i <= $#char; $i++) {
7007             if (0) {
7008             }
7009 0         0  
7010             # remain \\
7011             elsif ($char[$i] eq '\\\\') {
7012             }
7013              
7014 0         0 # escape $ @ / and \
7015             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7016             $char[$i] = '\\' . $char[$i];
7017             }
7018 0         0 }
7019 0         0  
7020 0         0 $delimiter = '/';
7021 0         0 $end_delimiter = '/';
7022             my $prematch = '';
7023             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7024             }
7025              
7026             #
7027             # escape regexp (s''here')
7028 0     16 0 0 #
7029             sub e_s2_q {
7030 16         32 my($ope,$delimiter,$end_delimiter,$string) = @_;
7031              
7032 16         20 $slash = 'div';
7033 16         93  
7034 16 100       43 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7035             for (my $i=0; $i <= $#char; $i++) {
7036             if (0) {
7037             }
7038 9         31  
7039             # not escape \\
7040             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7041             }
7042              
7043 0         0 # escape $ @ / and \
7044             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7045             $char[$i] = '\\' . $char[$i];
7046             }
7047 5         13 }
7048              
7049             return join '', $ope, $delimiter, @char, $end_delimiter;
7050             }
7051              
7052             #
7053             # escape regexp (s/here/and here/modifier)
7054 16     97 0 49 #
7055 97   100     840 sub e_sub {
7056             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7057 97         466 $modifier ||= '';
7058 97 50       201  
7059 97         2810 $modifier =~ tr/p//d;
7060 0         0 if ($modifier =~ /([adlu])/oxms) {
7061 0 0       0 my $line = 0;
7062 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7063 0         0 if ($filename ne __FILE__) {
7064             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7065             last;
7066 0         0 }
7067             }
7068             die qq{Unsupported modifier "$1" used at line $line.\n};
7069 0 100       0 }
7070 97         278  
7071 36         44 if ($variable eq '') {
7072             $variable = '$_';
7073             $bind_operator = ' =~ ';
7074 36         54 }
7075              
7076             $slash = 'div';
7077              
7078             # P.128 Start of match (or end of previous match): \G
7079             # P.130 Advanced Use of \G with Perl
7080             # in Chapter 3: Overview of Regular Expression Features and Flavors
7081             # P.312 Iterative Matching: Scalar Context, with /g
7082             # in Chapter 7: Perl
7083             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7084              
7085             # P.181 Where You Left Off: The \G Assertion
7086             # in Chapter 5: Pattern Matching
7087             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7088              
7089             # P.220 Where You Left Off: The \G Assertion
7090             # in Chapter 5: Pattern Matching
7091 97         176 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7092 97         158  
7093             my $e_modifier = $modifier =~ tr/e//d;
7094 97         149 my $r_modifier = $modifier =~ tr/r//d;
7095 97 50       149  
7096 97         258 my $my = '';
7097 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7098 0         0 $my = $variable;
7099             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7100             $variable =~ s/ = .+ \z//oxms;
7101 0         0 }
7102 97         280  
7103             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7104             $variable_basename =~ s/ \s+ \z//oxms;
7105 97         177  
7106 97 100       225 # quote replacement string
7107 97         261 my $e_replacement = '';
7108 17         35 if ($e_modifier >= 1) {
7109             $e_replacement = e_qq('', '', '', $replacement);
7110             $e_modifier--;
7111 17 100       27 }
7112 80         231 else {
7113             if ($delimiter2 eq "'") {
7114             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7115 16         30 }
7116             else {
7117             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7118             }
7119 64         177 }
7120              
7121             my $sub = '';
7122 97 100       176  
7123 97 100       405 # with /r
7124             if ($r_modifier) {
7125             if (0) {
7126             }
7127 8         24  
7128 0 50       0 # s///gr without multibyte anchoring
7129             elsif ($modifier =~ /g/oxms) {
7130             $sub = sprintf(
7131             # 1 2 3 4 5
7132             q,
7133              
7134             $variable, # 1
7135             ($delimiter1 eq "'") ? # 2
7136             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7137             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7138             $s_matched, # 3
7139             $e_replacement, # 4
7140             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 5
7141             );
7142             }
7143              
7144             # s///r
7145 4         18 else {
7146              
7147 4 50       8 my $prematch = q{$`};
7148              
7149             $sub = sprintf(
7150             # 1 2 3 4 5 6 7
7151             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin8::re_r=%s; %s"%s$Elatin8::re_r$'" } : %s>,
7152              
7153             $variable, # 1
7154             ($delimiter1 eq "'") ? # 2
7155             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7156             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7157             $s_matched, # 3
7158             $e_replacement, # 4
7159             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 5
7160             $prematch, # 6
7161             $variable, # 7
7162             );
7163             }
7164 4 50       27  
7165 8         33 # $var !~ s///r doesn't make sense
7166             if ($bind_operator =~ / !~ /oxms) {
7167             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7168             }
7169             }
7170              
7171 0 100       0 # without /r
7172             else {
7173             if (0) {
7174             }
7175 89         206  
7176 0 100       0 # s///g without multibyte anchoring
    100          
7177             elsif ($modifier =~ /g/oxms) {
7178             $sub = sprintf(
7179             # 1 2 3 4 5 6 7 8
7180             q,
7181              
7182             $variable, # 1
7183             ($delimiter1 eq "'") ? # 2
7184             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7185             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7186             $s_matched, # 3
7187             $e_replacement, # 4
7188             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 5
7189             $variable, # 6
7190             $variable, # 7
7191             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7192             );
7193             }
7194              
7195             # s///
7196 22         96 else {
7197              
7198 67 100       108 my $prematch = q{$`};
    100          
7199              
7200             $sub = sprintf(
7201              
7202             ($bind_operator =~ / =~ /oxms) ?
7203              
7204             # 1 2 3 4 5 6 7 8
7205             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin8::re_r=%s; %s%s="%s$Elatin8::re_r$'"; 1 } : undef> :
7206              
7207             # 1 2 3 4 5 6 7 8
7208             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin8::re_r=%s; %s%s="%s$Elatin8::re_r$'"; undef }>,
7209              
7210             $variable, # 1
7211             $bind_operator, # 2
7212             ($delimiter1 eq "'") ? # 3
7213             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7214             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7215             $s_matched, # 4
7216             $e_replacement, # 5
7217             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 6
7218             $variable, # 7
7219             $prematch, # 8
7220             );
7221             }
7222             }
7223 67 50       386  
7224 97         306 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7225             if ($my ne '') {
7226             $sub = "($my, $sub)[1]";
7227             }
7228 0         0  
7229 97         268 # clear s/// variable
7230             $sub_variable = '';
7231 97         162 $bind_operator = '';
7232              
7233             return $sub;
7234             }
7235              
7236             #
7237             # escape regexp of split qr//
7238 97     74 0 769 #
7239 74   100     678 sub e_split {
7240             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7241 74         399 $modifier ||= '';
7242 74 50       160  
7243 74         197 $modifier =~ tr/p//d;
7244 0         0 if ($modifier =~ /([adlu])/oxms) {
7245 0 0       0 my $line = 0;
7246 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7247 0         0 if ($filename ne __FILE__) {
7248             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7249             last;
7250 0         0 }
7251             }
7252             die qq{Unsupported modifier "$1" used at line $line.\n};
7253 0         0 }
7254              
7255             $slash = 'div';
7256 74 50       140  
7257 74         179 # /b /B modifier
7258             if ($modifier =~ tr/bB//d) {
7259             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7260 0 50       0 }
7261 74         184  
7262             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7263             my $metachar = qr/[\@\\|[\]{^]/oxms;
7264 74         280  
7265             # split regexp
7266             my @char = $string =~ /\G((?>
7267             [^\\\$\@\[\(] |
7268             \\x (?>[0-9A-Fa-f]{1,2}) |
7269             \\ (?>[0-7]{2,3}) |
7270             \\c [\x40-\x5F] |
7271             \\x\{ (?>[0-9A-Fa-f]+) \} |
7272             \\o\{ (?>[0-7]+) \} |
7273             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7274             \\ $q_char |
7275             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7276             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7277             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7278             [\$\@] $qq_variable |
7279             \$ (?>\s* [0-9]+) |
7280             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7281             \$ \$ (?![\w\{]) |
7282             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7283             \[\^ |
7284             \[\: (?>[a-z]+) :\] |
7285             \[\:\^ (?>[a-z]+) :\] |
7286             \(\? |
7287             $q_char
7288 74         12079 ))/oxmsg;
7289 74         247  
7290 74         130 my $left_e = 0;
7291             my $right_e = 0;
7292             for (my $i=0; $i <= $#char; $i++) {
7293 74 50 33     470  
    50 33        
    100          
    100          
    50          
    50          
7294 249         1339 # "\L\u" --> "\u\L"
7295             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7296             @char[$i,$i+1] = @char[$i+1,$i];
7297             }
7298              
7299 0         0 # "\U\l" --> "\l\U"
7300             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7301             @char[$i,$i+1] = @char[$i+1,$i];
7302             }
7303              
7304 0         0 # octal escape sequence
7305             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7306             $char[$i] = Elatin8::octchr($1);
7307             }
7308              
7309 1         4 # hexadecimal escape sequence
7310             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7311             $char[$i] = Elatin8::hexchr($1);
7312             }
7313              
7314             # \b{...} --> b\{...}
7315             # \B{...} --> B\{...}
7316             # \N{CHARNAME} --> N\{CHARNAME}
7317             # \p{PROPERTY} --> p\{PROPERTY}
7318 1         3 # \P{PROPERTY} --> P\{PROPERTY}
7319             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7320             $char[$i] = $1 . '\\' . $2;
7321             }
7322              
7323 0         0 # \p, \P, \X --> p, P, X
7324             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7325             $char[$i] = $1;
7326 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          
7327              
7328             if (0) {
7329             }
7330 249         1631  
7331 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7332 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7333             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)) {
7334             $char[$i] .= join '', splice @char, $i+1, 3;
7335 0         0 }
7336             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)) {
7337             $char[$i] .= join '', splice @char, $i+1, 2;
7338 0         0 }
7339             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)) {
7340             $char[$i] .= join '', splice @char, $i+1, 1;
7341             }
7342             }
7343              
7344 0         0 # open character class [...]
7345 3 50       7 elsif ($char[$i] eq '[') {
7346 3         10 my $left = $i;
7347             if ($char[$i+1] eq ']') {
7348 0         0 $i++;
7349 3 50       5 }
7350 7         14 while (1) {
7351             if (++$i > $#char) {
7352 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7353 7         15 }
7354             if ($char[$i] eq ']') {
7355             my $right = $i;
7356 3 50       12  
7357 3         19 # [...]
  0         0  
7358             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7359             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7360 0         0 }
7361             else {
7362             splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
7363 3         17 }
7364 3         6  
7365             $i = $left;
7366             last;
7367             }
7368             }
7369             }
7370              
7371 3         7 # open character class [^...]
7372 0 0       0 elsif ($char[$i] eq '[^') {
7373 0         0 my $left = $i;
7374             if ($char[$i+1] eq ']') {
7375 0         0 $i++;
7376 0 0       0 }
7377 0         0 while (1) {
7378             if (++$i > $#char) {
7379 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7380 0         0 }
7381             if ($char[$i] eq ']') {
7382             my $right = $i;
7383 0 0       0  
7384 0         0 # [^...]
  0         0  
7385             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7386             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7387 0         0 }
7388             else {
7389             splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7390 0         0 }
7391 0         0  
7392             $i = $left;
7393             last;
7394             }
7395             }
7396             }
7397              
7398 0         0 # rewrite character class or escape character
7399             elsif (my $char = character_class($char[$i],$modifier)) {
7400             $char[$i] = $char;
7401             }
7402              
7403             # P.794 29.2.161. split
7404             # in Chapter 29: Functions
7405             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7406              
7407             # P.951 split
7408             # in Chapter 27: Functions
7409             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7410              
7411             # said "The //m modifier is assumed when you split on the pattern /^/",
7412             # but perl5.008 is not so. Therefore, this software adds //m.
7413             # (and so on)
7414              
7415 1         3 # split(m/^/) --> split(m/^/m)
7416             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7417             $modifier .= 'm';
7418             }
7419              
7420 7 0       25 # /i modifier
7421 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
7422             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
7423             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
7424 0         0 }
7425             else {
7426             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
7427             }
7428             }
7429              
7430 0 0       0 # \u \l \U \L \F \Q \E
7431 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7432             if ($right_e < $left_e) {
7433             $char[$i] = '\\' . $char[$i];
7434             }
7435 0         0 }
7436 0         0 elsif ($char[$i] eq '\u') {
7437             $char[$i] = '@{[Elatin8::ucfirst qq<';
7438             $left_e++;
7439 0         0 }
7440 0         0 elsif ($char[$i] eq '\l') {
7441             $char[$i] = '@{[Elatin8::lcfirst qq<';
7442             $left_e++;
7443 0         0 }
7444 0         0 elsif ($char[$i] eq '\U') {
7445             $char[$i] = '@{[Elatin8::uc qq<';
7446             $left_e++;
7447 0         0 }
7448 0         0 elsif ($char[$i] eq '\L') {
7449             $char[$i] = '@{[Elatin8::lc qq<';
7450             $left_e++;
7451 0         0 }
7452 0         0 elsif ($char[$i] eq '\F') {
7453             $char[$i] = '@{[Elatin8::fc qq<';
7454             $left_e++;
7455 0         0 }
7456 0         0 elsif ($char[$i] eq '\Q') {
7457             $char[$i] = '@{[CORE::quotemeta qq<';
7458             $left_e++;
7459 0 0       0 }
7460 0         0 elsif ($char[$i] eq '\E') {
7461 0         0 if ($right_e < $left_e) {
7462             $char[$i] = '>]}';
7463             $right_e++;
7464 0         0 }
7465             else {
7466             $char[$i] = '';
7467             }
7468 0         0 }
7469 0 0       0 elsif ($char[$i] eq '\Q') {
7470 0         0 while (1) {
7471             if (++$i > $#char) {
7472 0 0       0 last;
7473 0         0 }
7474             if ($char[$i] eq '\E') {
7475             last;
7476             }
7477             }
7478             }
7479             elsif ($char[$i] eq '\E') {
7480             }
7481              
7482 0 0       0 # $0 --> $0
7483 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7484             if ($ignorecase) {
7485             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7486             }
7487 0 0       0 }
7488 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7489             if ($ignorecase) {
7490             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7491             }
7492             }
7493              
7494             # $$ --> $$
7495             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7496             }
7497              
7498             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7499 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7500 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7501 0         0 $char[$i] = e_capture($1);
7502             if ($ignorecase) {
7503             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7504             }
7505 0         0 }
7506 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7507 0         0 $char[$i] = e_capture($1);
7508             if ($ignorecase) {
7509             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7510             }
7511             }
7512              
7513 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7514 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) {
7515 0         0 $char[$i] = e_capture($1.'->'.$2);
7516             if ($ignorecase) {
7517             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7518             }
7519             }
7520              
7521 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7522 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) {
7523 0         0 $char[$i] = e_capture($1.'->'.$2);
7524             if ($ignorecase) {
7525             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7526             }
7527             }
7528              
7529 0         0 # $$foo
7530 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7531 0         0 $char[$i] = e_capture($1);
7532             if ($ignorecase) {
7533             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7534             }
7535             }
7536              
7537 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
7538 12         39 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7539             if ($ignorecase) {
7540             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
7541 0         0 }
7542             else {
7543             $char[$i] = '@{[Elatin8::PREMATCH()]}';
7544             }
7545             }
7546              
7547 12 50       56 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
7548 12         32 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7549             if ($ignorecase) {
7550             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
7551 0         0 }
7552             else {
7553             $char[$i] = '@{[Elatin8::MATCH()]}';
7554             }
7555             }
7556              
7557 12 50       54 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
7558 9         24 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7559             if ($ignorecase) {
7560             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
7561 0         0 }
7562             else {
7563             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
7564             }
7565             }
7566              
7567 9 0       41 # ${ foo }
7568 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) {
7569             if ($ignorecase) {
7570             $char[$i] = '@{[Elatin8::ignorecase(' . $1 . ')]}';
7571             }
7572             }
7573              
7574 0         0 # ${ ... }
7575 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7576 0         0 $char[$i] = e_capture($1);
7577             if ($ignorecase) {
7578             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7579             }
7580             }
7581              
7582 0         0 # $scalar or @array
7583 3 50       15 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7584 3         17 $char[$i] = e_string($char[$i]);
7585             if ($ignorecase) {
7586             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7587             }
7588             }
7589              
7590 0 50       0 # quote character before ? + * {
7591             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7592             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7593 1         7 }
7594             else {
7595             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7596             }
7597             }
7598             }
7599 0         0  
7600 74 50       231 # make regexp string
7601 74         177 $modifier =~ tr/i//d;
7602             if ($left_e > $right_e) {
7603 0         0 return join '', 'Elatin8::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7604             }
7605             return join '', 'Elatin8::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7606             }
7607              
7608             #
7609             # escape regexp of split qr''
7610 74     0 0 2235 #
7611 0   0       sub e_split_q {
7612             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7613 0           $modifier ||= '';
7614 0 0          
7615 0           $modifier =~ tr/p//d;
7616 0           if ($modifier =~ /([adlu])/oxms) {
7617 0 0         my $line = 0;
7618 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7619 0           if ($filename ne __FILE__) {
7620             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7621             last;
7622 0           }
7623             }
7624             die qq{Unsupported modifier "$1" used at line $line.\n};
7625 0           }
7626              
7627             $slash = 'div';
7628 0 0          
7629 0           # /b /B modifier
7630             if ($modifier =~ tr/bB//d) {
7631             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7632 0 0         }
7633              
7634             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7635 0            
7636             # split regexp
7637             my @char = $string =~ /\G((?>
7638             [^\\\[] |
7639             [\x00-\xFF] |
7640             \[\^ |
7641             \[\: (?>[a-z]+) \:\] |
7642             \[\:\^ (?>[a-z]+) \:\] |
7643             \\ (?:$q_char) |
7644             (?:$q_char)
7645             ))/oxmsg;
7646 0            
7647 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7648             for (my $i=0; $i <= $#char; $i++) {
7649             if (0) {
7650             }
7651 0            
7652 0           # open character class [...]
7653 0 0         elsif ($char[$i] eq '[') {
7654 0           my $left = $i;
7655             if ($char[$i+1] eq ']') {
7656 0           $i++;
7657 0 0         }
7658 0           while (1) {
7659             if (++$i > $#char) {
7660 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7661 0           }
7662             if ($char[$i] eq ']') {
7663             my $right = $i;
7664 0            
7665             # [...]
7666 0           splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
7667 0            
7668             $i = $left;
7669             last;
7670             }
7671             }
7672             }
7673              
7674 0           # open character class [^...]
7675 0 0         elsif ($char[$i] eq '[^') {
7676 0           my $left = $i;
7677             if ($char[$i+1] eq ']') {
7678 0           $i++;
7679 0 0         }
7680 0           while (1) {
7681             if (++$i > $#char) {
7682 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7683 0           }
7684             if ($char[$i] eq ']') {
7685             my $right = $i;
7686 0            
7687             # [^...]
7688 0           splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7689 0            
7690             $i = $left;
7691             last;
7692             }
7693             }
7694             }
7695              
7696 0           # rewrite character class or escape character
7697             elsif (my $char = character_class($char[$i],$modifier)) {
7698             $char[$i] = $char;
7699             }
7700              
7701 0           # split(m/^/) --> split(m/^/m)
7702             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7703             $modifier .= 'm';
7704             }
7705              
7706 0 0         # /i modifier
7707 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
7708             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
7709             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
7710 0           }
7711             else {
7712             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
7713             }
7714             }
7715              
7716 0 0         # quote character before ? + * {
7717             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7718             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7719 0           }
7720             else {
7721             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7722             }
7723             }
7724 0           }
7725 0            
7726             $modifier =~ tr/i//d;
7727             return join '', 'Elatin8::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7728             }
7729              
7730             #
7731             # instead of Carp::carp
7732 0     0 0   #
7733 0           sub carp {
7734             my($package,$filename,$line) = caller(1);
7735             print STDERR "@_ at $filename line $line.\n";
7736             }
7737              
7738             #
7739             # instead of Carp::croak
7740 0     0 0   #
7741 0           sub croak {
7742 0           my($package,$filename,$line) = caller(1);
7743             print STDERR "@_ at $filename line $line.\n";
7744             die "\n";
7745             }
7746              
7747             #
7748             # instead of Carp::cluck
7749 0     0 0   #
7750 0           sub cluck {
7751 0           my $i = 0;
7752 0           my @cluck = ();
7753 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7754             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7755 0           $i++;
7756 0           }
7757 0           print STDERR CORE::reverse @cluck;
7758             print STDERR "\n";
7759             print STDERR @_;
7760             }
7761              
7762             #
7763             # instead of Carp::confess
7764 0     0 0   #
7765 0           sub confess {
7766 0           my $i = 0;
7767 0           my @confess = ();
7768 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7769             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7770 0           $i++;
7771 0           }
7772 0           print STDERR CORE::reverse @confess;
7773 0           print STDERR "\n";
7774             print STDERR @_;
7775             die "\n";
7776             }
7777              
7778             1;
7779              
7780             __END__