File Coverage

blib/lib/Elatin6.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 Elatin6;
2 204     204   3294 use strict;
  204         363  
  204         23866  
3             ######################################################################
4             #
5             # Elatin6 - Run-time routines for Latin6.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin6/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   3356 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         4773  
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         353  
  204         40834  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1833 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         499 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         48066 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   13997 CORE::eval q{
  204     204   1172  
  204     86   440  
  204         25255  
  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       86771 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 (Elatin6::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Elatin6::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   2107 no strict qw(refs);
  204         371  
  204         14985  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   1217 no strict qw(refs);
  204     0   354  
  204         38154  
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   1738 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         579  
  204         14447  
154 204     204   1261 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         1428  
  204         439921  
155              
156             #
157             # Latin-6 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Latin-6 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 Elatin6 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xA1" => "\xB1", # LATIN LETTER A WITH OGONEK
185             "\xA2" => "\xB2", # LATIN LETTER E WITH MACRON
186             "\xA3" => "\xB3", # LATIN LETTER G WITH CEDILLA
187             "\xA4" => "\xB4", # LATIN LETTER I WITH MACRON
188             "\xA5" => "\xB5", # LATIN LETTER I WITH TILDE
189             "\xA6" => "\xB6", # LATIN LETTER K WITH CEDILLA
190             "\xA8" => "\xB8", # LATIN LETTER L WITH CEDILLA
191             "\xA9" => "\xB9", # LATIN LETTER D WITH STROKE
192             "\xAA" => "\xBA", # LATIN LETTER S WITH CARON
193             "\xAB" => "\xBB", # LATIN LETTER T WITH STROKE
194             "\xAC" => "\xBC", # LATIN LETTER Z WITH CARON
195             "\xAE" => "\xBE", # LATIN LETTER U WITH MACRON
196             "\xAF" => "\xBF", # LATIN LETTER ENG
197             "\xC0" => "\xE0", # LATIN LETTER A WITH MACRON
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 I WITH OGONEK
205             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
206             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
207             "\xCA" => "\xEA", # LATIN LETTER E WITH OGONEK
208             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
209             "\xCC" => "\xEC", # LATIN LETTER E WITH DOT ABOVE
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 ETH (Icelandic)
214             "\xD1" => "\xF1", # LATIN LETTER N WITH CEDILLA
215             "\xD2" => "\xF2", # LATIN LETTER O WITH MACRON
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 U WITH TILDE
221             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
222             "\xD9" => "\xF9", # LATIN LETTER U WITH OGONEK
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 THORN (Icelandic)
228             );
229              
230             %uc = (%uc,
231             "\xB1" => "\xA1", # LATIN LETTER A WITH OGONEK
232             "\xB2" => "\xA2", # LATIN LETTER E WITH MACRON
233             "\xB3" => "\xA3", # LATIN LETTER G WITH CEDILLA
234             "\xB4" => "\xA4", # LATIN LETTER I WITH MACRON
235             "\xB5" => "\xA5", # LATIN LETTER I WITH TILDE
236             "\xB6" => "\xA6", # LATIN LETTER K WITH CEDILLA
237             "\xB8" => "\xA8", # LATIN LETTER L WITH CEDILLA
238             "\xB9" => "\xA9", # LATIN LETTER D WITH STROKE
239             "\xBA" => "\xAA", # LATIN LETTER S WITH CARON
240             "\xBB" => "\xAB", # LATIN LETTER T WITH STROKE
241             "\xBC" => "\xAC", # LATIN LETTER Z WITH CARON
242             "\xBE" => "\xAE", # LATIN LETTER U WITH MACRON
243             "\xBF" => "\xAF", # LATIN LETTER ENG
244             "\xE0" => "\xC0", # LATIN LETTER A WITH MACRON
245             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
246             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
247             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
248             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
249             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
250             "\xE6" => "\xC6", # LATIN LETTER AE
251             "\xE7" => "\xC7", # LATIN LETTER I WITH OGONEK
252             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
253             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
254             "\xEA" => "\xCA", # LATIN LETTER E WITH OGONEK
255             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
256             "\xEC" => "\xCC", # LATIN LETTER E WITH DOT ABOVE
257             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
258             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
259             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
260             "\xF0" => "\xD0", # LATIN LETTER ETH (Icelandic)
261             "\xF1" => "\xD1", # LATIN LETTER N WITH CEDILLA
262             "\xF2" => "\xD2", # LATIN LETTER O WITH MACRON
263             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
264             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
265             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
266             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
267             "\xF7" => "\xD7", # LATIN LETTER U WITH TILDE
268             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
269             "\xF9" => "\xD9", # LATIN LETTER U WITH OGONEK
270             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
271             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
272             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
273             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
274             "\xFE" => "\xDE", # LATIN LETTER THORN (Icelandic)
275             );
276              
277             %fc = (%fc,
278             "\xA1" => "\xB1", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
279             "\xA2" => "\xB2", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
280             "\xA3" => "\xB3", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
281             "\xA4" => "\xB4", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
282             "\xA5" => "\xB5", # LATIN CAPITAL LETTER I WITH TILDE --> LATIN SMALL LETTER I WITH TILDE
283             "\xA6" => "\xB6", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
284             "\xA8" => "\xB8", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
285             "\xA9" => "\xB9", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
286             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
287             "\xAB" => "\xBB", # LATIN CAPITAL LETTER T WITH STROKE --> LATIN SMALL LETTER T WITH STROKE
288             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
289             "\xAE" => "\xBE", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
290             "\xAF" => "\xBF", # LATIN CAPITAL LETTER ENG --> LATIN SMALL LETTER ENG
291             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
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 I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
299             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
300             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
301             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
302             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
303             "\xCC" => "\xEC", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
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 ETH --> LATIN SMALL LETTER ETH
308             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
309             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
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 U WITH TILDE --> LATIN SMALL LETTER U WITH TILDE
315             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
316             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
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 THORN --> LATIN SMALL LETTER THORN
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 = Elatin6::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 = Elatin6::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 = \&Latin6::ord;
368 0         0 *Char::ord_ = \&Latin6::ord_;
369 0         0 *Char::reverse = \&Latin6::reverse;
370 0         0 *Char::getc = \&Latin6::getc;
371 0         0 *Char::length = \&Latin6::length;
372 0         0 *Char::substr = \&Latin6::substr;
373 0         0 *Char::index = \&Latin6::index;
374 0         0 *Char::rindex = \&Latin6::rindex;
375 0         0 *Char::eval = \&Latin6::eval;
376 0         0 *Char::escape = \&Latin6::escape;
377 0         0 *Char::escape_token = \&Latin6::escape_token;
378 0         0 *Char::escape_script = \&Latin6::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 Elatin6::split(;$$$);
404             sub Elatin6::tr($$$$;$);
405             sub Elatin6::chop(@);
406             sub Elatin6::index($$;$);
407             sub Elatin6::rindex($$;$);
408             sub Elatin6::lcfirst(@);
409             sub Elatin6::lcfirst_();
410             sub Elatin6::lc(@);
411             sub Elatin6::lc_();
412             sub Elatin6::ucfirst(@);
413             sub Elatin6::ucfirst_();
414             sub Elatin6::uc(@);
415             sub Elatin6::uc_();
416             sub Elatin6::fc(@);
417             sub Elatin6::fc_();
418             sub Elatin6::ignorecase;
419             sub Elatin6::classic_character_class;
420             sub Elatin6::capture;
421             sub Elatin6::chr(;$);
422             sub Elatin6::chr_();
423             sub Elatin6::glob($);
424             sub Elatin6::glob_();
425              
426             sub Latin6::ord(;$);
427             sub Latin6::ord_();
428             sub Latin6::reverse(@);
429             sub Latin6::getc(;*@);
430             sub Latin6::length(;$);
431             sub Latin6::substr($$;$$);
432             sub Latin6::index($$;$);
433             sub Latin6::rindex($$;$);
434             sub Latin6::escape(;$);
435              
436             #
437             # Regexp work
438             #
439 204         20084 use vars qw(
440             $re_a
441             $re_t
442             $re_n
443             $re_r
444 204     204   1767 );
  204         403  
445              
446             #
447             # Character class
448             #
449 204         2231599 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   1185 );
  204         369  
478              
479             ${Elatin6::dot} = qr{(?>[^\x0A])};
480             ${Elatin6::dot_s} = qr{(?>[\x00-\xFF])};
481             ${Elatin6::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             # ${Elatin6::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
487             # ${Elatin6::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
488             ${Elatin6::eS} = qr{(?>[^\s])};
489              
490             ${Elatin6::eW} = qr{(?>[^0-9A-Z_a-z])};
491             ${Elatin6::eH} = qr{(?>[^\x09\x20])};
492             ${Elatin6::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
493             ${Elatin6::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
494             ${Elatin6::eN} = qr{(?>[^\x0A])};
495             ${Elatin6::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
496             ${Elatin6::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
497             ${Elatin6::not_ascii} = qr{(?>[^\x00-\x7F])};
498             ${Elatin6::not_blank} = qr{(?>[^\x09\x20])};
499             ${Elatin6::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
500             ${Elatin6::not_digit} = qr{(?>[^\x30-\x39])};
501             ${Elatin6::not_graph} = qr{(?>[^\x21-\x7F])};
502             ${Elatin6::not_lower} = qr{(?>[^\x61-\x7A])};
503             ${Elatin6::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
504             # ${Elatin6::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
505             ${Elatin6::not_print} = qr{(?>[^\x20-\x7F])};
506             ${Elatin6::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
507             ${Elatin6::not_space} = qr{(?>[^\s\x0B])};
508             ${Elatin6::not_upper} = qr{(?>[^\x41-\x5A])};
509             ${Elatin6::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
510             # ${Elatin6::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
511             ${Elatin6::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
512             ${Elatin6::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
513             ${Elatin6::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             ${Elatin6::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 "Elatin6::foo" used only once: possible typo at here.
517             ${Elatin6::dot} = ${Elatin6::dot};
518             ${Elatin6::dot_s} = ${Elatin6::dot_s};
519             ${Elatin6::eD} = ${Elatin6::eD};
520             ${Elatin6::eS} = ${Elatin6::eS};
521             ${Elatin6::eW} = ${Elatin6::eW};
522             ${Elatin6::eH} = ${Elatin6::eH};
523             ${Elatin6::eV} = ${Elatin6::eV};
524             ${Elatin6::eR} = ${Elatin6::eR};
525             ${Elatin6::eN} = ${Elatin6::eN};
526             ${Elatin6::not_alnum} = ${Elatin6::not_alnum};
527             ${Elatin6::not_alpha} = ${Elatin6::not_alpha};
528             ${Elatin6::not_ascii} = ${Elatin6::not_ascii};
529             ${Elatin6::not_blank} = ${Elatin6::not_blank};
530             ${Elatin6::not_cntrl} = ${Elatin6::not_cntrl};
531             ${Elatin6::not_digit} = ${Elatin6::not_digit};
532             ${Elatin6::not_graph} = ${Elatin6::not_graph};
533             ${Elatin6::not_lower} = ${Elatin6::not_lower};
534             ${Elatin6::not_lower_i} = ${Elatin6::not_lower_i};
535             ${Elatin6::not_print} = ${Elatin6::not_print};
536             ${Elatin6::not_punct} = ${Elatin6::not_punct};
537             ${Elatin6::not_space} = ${Elatin6::not_space};
538             ${Elatin6::not_upper} = ${Elatin6::not_upper};
539             ${Elatin6::not_upper_i} = ${Elatin6::not_upper_i};
540             ${Elatin6::not_word} = ${Elatin6::not_word};
541             ${Elatin6::not_xdigit} = ${Elatin6::not_xdigit};
542             ${Elatin6::eb} = ${Elatin6::eb};
543             ${Elatin6::eB} = ${Elatin6::eB};
544              
545             #
546             # Latin-6 split
547             #
548             sub Elatin6::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-6 transliteration (tr///)
758             #
759             sub Elatin6::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-6 chop
849             #
850             sub Elatin6::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-6 index by octet
870             #
871             sub Elatin6::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-6 reverse index
895             #
896             sub Elatin6::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-6 lower case first with parameter
919             #
920             sub Elatin6::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 Elatin6::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
925             }
926             else {
927 0         0 return Elatin6::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
928             }
929             }
930             else {
931 0         0 return Elatin6::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
932             }
933             }
934              
935             #
936             # Latin-6 lower case first without parameter
937             #
938             sub Elatin6::lcfirst_() {
939 0     0 0 0 return Elatin6::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
940             }
941              
942             #
943             # Latin-6 lower case with parameter
944             #
945             sub Elatin6::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 Elatin6::lc_();
957             }
958             }
959              
960             #
961             # Latin-6 lower case without parameter
962             #
963             sub Elatin6::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-6 upper case first with parameter
970             #
971             sub Elatin6::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 Elatin6::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
976             }
977             else {
978 0         0 return Elatin6::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
979             }
980             }
981             else {
982 0         0 return Elatin6::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
983             }
984             }
985              
986             #
987             # Latin-6 upper case first without parameter
988             #
989             sub Elatin6::ucfirst_() {
990 0     0 0 0 return Elatin6::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
991             }
992              
993             #
994             # Latin-6 upper case with parameter
995             #
996             sub Elatin6::uc(@) {
997 0 50   174 0 0 if (@_) {
998 174         281 my $s = shift @_;
999 174 50 33     263 if (@_ and wantarray) {
1000 174 0       373 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         593  
1004             }
1005             }
1006             else {
1007 174         1264 return Elatin6::uc_();
1008             }
1009             }
1010              
1011             #
1012             # Latin-6 upper case without parameter
1013             #
1014             sub Elatin6::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-6 fold case with parameter
1021             #
1022             sub Elatin6::fc(@) {
1023 0 50   197 0 0 if (@_) {
1024 197         292 my $s = shift @_;
1025 197 50 33     238 if (@_ and wantarray) {
1026 197 0       425 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         743  
1030             }
1031             }
1032             else {
1033 197         1103 return Elatin6::fc_();
1034             }
1035             }
1036              
1037             #
1038             # Latin-6 fold case without parameter
1039             #
1040             sub Elatin6::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-6 regexp capture
1047             #
1048             {
1049             sub Elatin6::capture {
1050 0     0 1 0 return $_[0];
1051             }
1052             }
1053              
1054             #
1055             # Latin-6 regexp ignore case modifier
1056             #
1057             sub Elatin6::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 = Elatin6::uc($char[$i]);
1154 0         0 my $fc = Elatin6::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 Elatin6::classic_character_class {
1192 0     1867 0 0 my($char) = @_;
1193              
1194             return {
1195             '\D' => '${Elatin6::eD}',
1196             '\S' => '${Elatin6::eS}',
1197             '\W' => '${Elatin6::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' => '${Elatin6::eH}',
1240             '\V' => '${Elatin6::eV}',
1241             '\h' => '[\x09\x20]',
1242             '\v' => '[\x0A\x0B\x0C\x0D]',
1243             '\R' => '${Elatin6::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' => '${Elatin6::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' => '${Elatin6::eb}',
1266              
1267             # \B really means (?:(?<=\w)(?=\w)|(?
1268             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1269             '\B' => '${Elatin6::eB}',
1270              
1271 1867   100     2663 }->{$char} || '';
1272             }
1273              
1274             #
1275             # prepare Latin-6 characters per length
1276             #
1277              
1278             # 1 octet characters
1279             my @chars1 = ();
1280             sub chars1 {
1281 1867 0   0 0 70696 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-6 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-6 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-6 octet range
1527             #
1528             sub _octets {
1529 0     182   0 my $length = shift @_;
1530              
1531 182 50       542 if ($length == 1) {
1532 182         383 my($a1) = unpack 'C', $_[0];
1533 182         506 my($z1) = unpack 'C', $_[1];
1534              
1535 182 50       343 if ($a1 > $z1) {
1536 182         388 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         448 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         1121 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1551             }
1552             }
1553              
1554             #
1555             # Latin-6 range regexp
1556             #
1557             sub _range_regexp {
1558 0     182   0 my($length,$first,$last) = @_;
1559              
1560 182         395 my @range_regexp = ();
1561 182 50       252 if (not exists $range_tr{$length}) {
1562 182         454 return @range_regexp;
1563             }
1564              
1565 0         0 my @ranges = @{ $range_tr{$length} };
  182         280  
1566 182         422 while (my @range = splice(@ranges,0,$length)) {
1567 182         744 my $min = '';
1568 182         283 my $max = '';
1569 182         215 for (my $i=0; $i < $length; $i++) {
1570 182         556 $min .= pack 'C', $range[$i][0];
1571 182         657 $max .= pack 'C', $range[$i][-1];
1572             }
1573              
1574             # min___max
1575             # FIRST_____________LAST
1576             # (nothing)
1577              
1578 182 50 33     564 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         1929 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         442 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-6 open character list for qr and not qr
1643             #
1644             sub _charlist {
1645              
1646 182     358   407 my $modifier = pop @_;
1647 358         852 my @char = @_;
1648              
1649 358 100       1094 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1650              
1651             # unescape character
1652 358         842 for (my $i=0; $i <= $#char; $i++) {
1653              
1654             # escape - to ...
1655 358 100 100     1217 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1656 1125 100 100     9547 if ((0 < $i) and ($i < $#char)) {
1657 206         894 $char[$i] = '...';
1658             }
1659             }
1660              
1661             # octal escape sequence
1662             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1663 182         393 $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         162 $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' => '${Elatin6::eD}',
1716             '\S' => '${Elatin6::eS}',
1717             '\W' => '${Elatin6::eW}',
1718              
1719             '\H' => '${Elatin6::eH}',
1720             '\V' => '${Elatin6::eV}',
1721             '\h' => '[\x09\x20]',
1722             '\v' => '[\x0A\x0B\x0C\x0D]',
1723             '\R' => '${Elatin6::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:]' => '${Elatin6::not_lower_i}',
1735             '[:^upper:]' => '${Elatin6::not_upper_i}',
1736              
1737 25         530 }->{$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:]' => '${Elatin6::not_alnum}',
1771             '[:^alpha:]' => '${Elatin6::not_alpha}',
1772             '[:^ascii:]' => '${Elatin6::not_ascii}',
1773             '[:^blank:]' => '${Elatin6::not_blank}',
1774             '[:^cntrl:]' => '${Elatin6::not_cntrl}',
1775             '[:^digit:]' => '${Elatin6::not_digit}',
1776             '[:^graph:]' => '${Elatin6::not_graph}',
1777             '[:^lower:]' => '${Elatin6::not_lower}',
1778             '[:^print:]' => '${Elatin6::not_print}',
1779             '[:^punct:]' => '${Elatin6::not_punct}',
1780             '[:^space:]' => '${Elatin6::not_space}',
1781             '[:^upper:]' => '${Elatin6::not_upper}',
1782             '[:^word:]' => '${Elatin6::not_word}',
1783             '[:^xdigit:]' => '${Elatin6::not_xdigit}',
1784              
1785 8         71 }->{$1};
1786             }
1787             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1788 70         1154 $char[$i] = $1;
1789             }
1790             }
1791              
1792             # open character list
1793 7         33 my @singleoctet = ();
1794 358         660 my @multipleoctet = ();
1795 358         571 for (my $i=0; $i <= $#char; ) {
1796              
1797             # escaped -
1798 358 100 100     845 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1799 943         4189 $i += 1;
1800 182         242 next;
1801             }
1802              
1803             # make range regexp
1804             elsif ($char[$i] eq '...') {
1805              
1806             # range error
1807 182 50       320 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1808 182         809 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         650 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         538 my @regexp = ();
1819              
1820             # is first and last
1821 182 50 33     278 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1822 182         799 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         506 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         351 push @singleoctet, @regexp;
1846             }
1847             else {
1848 182         558 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       649 if ($modifier =~ /i/oxms) {
1858 493         807 my $uc = Elatin6::uc($char[$i]);
1859 24         53 my $fc = Elatin6::fc($char[$i]);
1860 24 100       49 if ($uc ne $fc) {
1861 24 50       42 if (CORE::length($fc) == 1) {
1862 12         75 push @singleoctet, $uc, $fc;
1863             }
1864             else {
1865 12         101 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         27 push @singleoctet, $char[$i];
1875             }
1876 469         653 $i += 1;
1877             }
1878              
1879             # single character of single octet code
1880             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1881 493         797 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         11 push @multipleoctet, $char[$i];
1896 84         162 $i += 1;
1897             }
1898             }
1899              
1900             # quote metachar
1901 84         146 for (@singleoctet) {
1902 358 50       877 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1903 689         3028 $_ = '-';
1904             }
1905             elsif (/\A \n \z/oxms) {
1906 0         0 $_ = '\n';
1907             }
1908             elsif (/\A \r \z/oxms) {
1909 8         22 $_ = '\r';
1910             }
1911             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1912 8         20 $_ = sprintf('\x%02X', CORE::ord $1);
1913             }
1914             elsif (/\A [\x00-\xFF] \z/oxms) {
1915 60         199 $_ = quotemeta $_;
1916             }
1917             }
1918              
1919             # return character list
1920 429         642 return \@singleoctet, \@multipleoctet;
1921             }
1922              
1923             #
1924             # Latin-6 octal escape sequence
1925             #
1926             sub octchr {
1927 358     5 0 1241 my($octdigit) = @_;
1928              
1929 5         13 my @binary = ();
1930 5         8 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         27 }->{$octal};
1941             }
1942 50         177 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         15 }->{CORE::length($binary) % 8};
1956              
1957 5         55 return $octchr;
1958             }
1959              
1960             #
1961             # Latin-6 hexadecimal escape sequence
1962             #
1963             sub hexchr {
1964 5     5 0 16 my($hexdigit) = @_;
1965              
1966             my $hexchr = {
1967             1 => pack('H*', "0$hexdigit"),
1968             0 => pack('H*', "$hexdigit"),
1969              
1970 5         16 }->{CORE::length($_[0]) % 2};
1971              
1972 5         248 return $hexchr;
1973             }
1974              
1975             #
1976             # Latin-6 open character list for qr
1977             #
1978             sub charlist_qr {
1979              
1980 5     314 0 21 my $modifier = pop @_;
1981 314         578 my @char = @_;
1982              
1983 314         747 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1984 314         909 my @singleoctet = @$singleoctet;
1985 314         657 my @multipleoctet = @$multipleoctet;
1986              
1987             # return character list
1988 314 100       451 if (scalar(@singleoctet) >= 1) {
1989              
1990             # with /i modifier
1991 314 100       671 if ($modifier =~ m/i/oxms) {
1992 236         693 my %singleoctet_ignorecase = ();
1993 22         35 for (@singleoctet) {
1994 22   100     36 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1995 46         195 for my $ord (hex($1) .. hex($2)) {
1996 46         132 my $char = CORE::chr($ord);
1997 66         96 my $uc = Elatin6::uc($char);
1998 66         96 my $fc = Elatin6::fc($char);
1999 66 100       113 if ($uc eq $fc) {
2000 66         109 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2001             }
2002             else {
2003 12 50       127 if (CORE::length($fc) == 1) {
2004 54         76 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2005 54         113 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2006             }
2007             else {
2008 54         190 $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         28 my @singleoctet_ignorecase = ();
2020 22         28 for my $ord (0 .. 255) {
2021 22 100       34 if (exists $singleoctet_ignorecase{$ord}) {
2022 5632         7046 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         89  
2023             }
2024             else {
2025 96         253 $i++;
2026             }
2027             }
2028 5536         5974 @singleoctet = ();
2029 22         37 for my $range (@singleoctet_ignorecase) {
2030 22 100       104 if (ref $range) {
2031 3648 100       7288 if (scalar(@{$range}) == 1) {
  56 50       65  
2032 56         93 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         45  
2033             }
2034 36         138 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         22  
  20         23  
2039             }
2040             }
2041             }
2042             }
2043              
2044 20         81 my $not_anchor = '';
2045              
2046 236         352 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2047             }
2048 236 100       636 if (scalar(@multipleoctet) >= 2) {
2049 314         677 return '(?:' . join('|', @multipleoctet) . ')';
2050             }
2051             else {
2052 6         30 return $multipleoctet[0];
2053             }
2054             }
2055              
2056             #
2057             # Latin-6 open character list for not qr
2058             #
2059             sub charlist_not_qr {
2060              
2061 308     44 0 1252 my $modifier = pop @_;
2062 44         92 my @char = @_;
2063              
2064 44         341 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2065 44         194 my @singleoctet = @$singleoctet;
2066 44         101 my @multipleoctet = @$multipleoctet;
2067              
2068             # with /i modifier
2069 44 100       211 if ($modifier =~ m/i/oxms) {
2070 44         319 my %singleoctet_ignorecase = ();
2071 10         21 for (@singleoctet) {
2072 10   66     19 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2073 10         56 for my $ord (hex($1) .. hex($2)) {
2074 10         44 my $char = CORE::chr($ord);
2075 30         50 my $uc = Elatin6::uc($char);
2076 30         133 my $fc = Elatin6::fc($char);
2077 30 50       104 if ($uc eq $fc) {
2078 30         51 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2079             }
2080             else {
2081 0 50       0 if (CORE::length($fc) == 1) {
2082 30         46 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2083 30         121 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2084             }
2085             else {
2086 30         267 $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         32 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2094             }
2095             }
2096 0         0 my $i = 0;
2097 10         20 my @singleoctet_ignorecase = ();
2098 10         19 for my $ord (0 .. 255) {
2099 10 100       18 if (exists $singleoctet_ignorecase{$ord}) {
2100 2560         4717 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         58  
2101             }
2102             else {
2103 60         408 $i++;
2104             }
2105             }
2106 2500         4576 @singleoctet = ();
2107 10         21 for my $range (@singleoctet_ignorecase) {
2108 10 100       35 if (ref $range) {
2109 960 50       3464 if (scalar(@{$range}) == 1) {
  20 50       25  
2110 20         40 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2111             }
2112 0         0 elsif (scalar(@{$range}) == 2) {
2113 20         106 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         76  
  20         34  
2117             }
2118             }
2119             }
2120             }
2121              
2122             # return character list
2123 20 50       189 if (scalar(@multipleoctet) >= 1) {
2124 44 0       154 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         165 return '(?:[^' . join('', @singleoctet) . '])';
2140             }
2141             else {
2142              
2143             # any character
2144 44         418 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   2665 use Fcntl qw(O_RDONLY);
  204         505  
  204         28689  
2155 408         1126 return CORE::sysopen($_[0], $file, &O_RDONLY);
2156             }
2157              
2158             #
2159             # open file in append mode
2160             #
2161             sub _open_a {
2162 408     204   19373 my(undef,$file) = @_;
2163 204     204   14974 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         420  
  204         729281  
2164 204         726 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   74806 $| = 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         728 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         1802 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         468  
2247             }
2248              
2249             #
2250             # Latin-6 order to character (with parameter)
2251             #
2252             sub Elatin6::chr(;$) {
2253              
2254 204 0   0 0 20867981 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-6 order to character (without parameter)
2271             #
2272             sub Elatin6::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-6 path globbing (with parameter)
2291             #
2292             sub Elatin6::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-6 path globbing (without parameter)
2310             #
2311             sub Elatin6::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-6 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-6 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 = Elatin6::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 { Elatin6::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 (Elatin6::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 Elatin6::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-6 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-6 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 Elatin6::PREMATCH {
2652             return $`;
2653             }
2654              
2655             #
2656             # ${^MATCH}, $MATCH, $& the string that matched
2657 0     0 0 0 #
2658             sub Elatin6::MATCH {
2659             return $&;
2660             }
2661              
2662             #
2663             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2664 0     0 0 0 #
2665             sub Elatin6::POSTMATCH {
2666             return $';
2667             }
2668              
2669             #
2670             # Latin-6 character to order (with parameter)
2671             #
2672 0 0   0 1 0 sub Latin6::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-6 character to order (without parameter)
2691             #
2692 0 0   0 0 0 sub Latin6::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-6 reverse
2709             #
2710 0 0   0 0 0 sub Latin6::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-6 getc (with parameter, without parameter)
2728             #
2729 0     0 0 0 sub Latin6::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 Latin6::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 ${Elatin6::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-6 length by character
2750             #
2751 0 0   0 1 0 sub Latin6::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-6 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 177931 # 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 Latin6::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-6 index by character
2852             #
2853 0     0 1 0 sub Latin6::index($$;$) {
2854 0 0       0  
2855 0         0 my $index;
2856             if (@_ == 3) {
2857             $index = Elatin6::index($_[0], $_[1], CORE::length(Latin6::substr($_[0], 0, $_[2])));
2858 0         0 }
2859             else {
2860             $index = Elatin6::index($_[0], $_[1]);
2861 0 0       0 }
2862 0         0  
2863             if ($index == -1) {
2864             return -1;
2865 0         0 }
2866             else {
2867             return Latin6::length(CORE::substr $_[0], 0, $index);
2868             }
2869             }
2870              
2871             #
2872             # Latin-6 rindex by character
2873             #
2874 0     0 1 0 sub Latin6::rindex($$;$) {
2875 0 0       0  
2876 0         0 my $rindex;
2877             if (@_ == 3) {
2878             $rindex = Elatin6::rindex($_[0], $_[1], CORE::length(Latin6::substr($_[0], 0, $_[2])));
2879 0         0 }
2880             else {
2881             $rindex = Elatin6::rindex($_[0], $_[1]);
2882 0 0       0 }
2883 0         0  
2884             if ($rindex == -1) {
2885             return -1;
2886 0         0 }
2887             else {
2888             return Latin6::length(CORE::substr $_[0], 0, $rindex);
2889             }
2890             }
2891              
2892 204     204   1954 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         596  
  204         26562  
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 Latin6::ord()
2897             my $function_ord = 'ord';
2898              
2899             # ord to ord or Latin6::ord_
2900             my $function_ord_ = 'ord';
2901              
2902             # reverse to reverse or Latin6::reverse
2903             my $function_reverse = 'reverse';
2904              
2905             # getc to getc or Latin6::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   1786 my $anchor = '';
  204     0   385  
  204         10242855  
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 | Latin6::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-6 script
3021 0 50   204 0 0 #
3022             sub Latin6::escape(;$) {
3023             local($_) = $_[0] if @_;
3024              
3025             # P.359 The Study Function
3026             # in Chapter 7: Perl
3027 204         631 # 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         392 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3049 204         342  
3050 204         1238 my $e_script = '';
3051             while (not /\G \z/oxgc) { # member
3052             $e_script .= Latin6::escape_token();
3053 75097         120508 }
3054              
3055             return $e_script;
3056             }
3057              
3058             #
3059             # escape Latin-6 token of script
3060             #
3061             sub Latin6::escape_token {
3062              
3063 204     75097 0 29254 # \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     94116 # 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         3063312  
3084 12544 100       17361 if (/\G ( \n ) /oxgc) { # another member (and so on)
3085 12544         29817 my $heredoc = '';
3086             if (scalar(@heredoc_delimiter) >= 1) {
3087 174         237 $slash = 'm//';
3088 174         339  
3089             $heredoc = join '', @heredoc;
3090             @heredoc = ();
3091 174         309  
3092 174         402 # skip here document
3093             for my $heredoc_delimiter (@heredoc_delimiter) {
3094 174         1137 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3095             }
3096 174         331 @heredoc_delimiter = ();
3097              
3098 174         317 $here_script = '';
3099             }
3100             return "\n" . $heredoc;
3101             }
3102 12544         37388  
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         57475  
3118 1401         2011 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         4523  
3138             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3139 86 50       181 my $e_string = e_string($1);
    50          
3140 86         2585  
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         158 else {
3154             $slash = 'div';
3155             return $e_string;
3156             }
3157             }
3158              
3159 86         279 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
3160 4         12 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3161             $slash = 'div';
3162             return q{Elatin6::PREMATCH()};
3163             }
3164              
3165 4         16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
3166 28         50 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3167             $slash = 'div';
3168             return q{Elatin6::MATCH()};
3169             }
3170              
3171 28         87 # $', ${'} --> $', ${'}
3172 1         3 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3173             $slash = 'div';
3174             return $1;
3175             }
3176              
3177 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
3178 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3179             $slash = 'div';
3180             return q{Elatin6::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       3836 my $scalar = e_string($1);
    100          
3189 1671         7437  
3190 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3191 1         2 $tr_variable = $scalar;
3192 1         2 $bind_operator = $1;
3193             $slash = 'm//';
3194             return '';
3195 1         3 }
3196 61         129 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3197 61         141 $sub_variable = $scalar;
3198 61         88 $bind_operator = $1;
3199             $slash = 'm//';
3200             return '';
3201 61         175 }
3202 1609         2177 else {
3203             $slash = 'div';
3204             return $scalar;
3205             }
3206             }
3207              
3208 1609         4513 # end of statement
3209             elsif (/\G ( [,;] ) /oxgc) {
3210             $slash = 'm//';
3211 5020         8046  
3212             # clear tr/// variable
3213             $tr_variable = '';
3214 5020         6225  
3215             # clear s/// variable
3216 5020         5523 $sub_variable = '';
3217              
3218 5020         5766 $bind_operator = '';
3219              
3220             return $1;
3221             }
3222              
3223 5020         18157 # bareword
3224             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3225             return $1;
3226             }
3227              
3228 0         0 # $0 --> $0
3229 2         6 elsif (/\G ( \$ 0 ) /oxmsgc) {
3230             $slash = 'div';
3231             return $1;
3232 2         8 }
3233 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3234             $slash = 'div';
3235             return $1;
3236             }
3237              
3238 0         0 # $$ --> $$
3239 1         3 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         3 # $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         73 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         129 # $ @ # \ ' " / ? ( ) [ ] < >
3293 62         111 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3294             $slash = 'div';
3295             return $1;
3296             }
3297              
3298 62         200 # 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 ($_ = Elatin6::glob("' . $1 . '"))';
3309             }
3310              
3311 0         0 # while (glob)
3312             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3313             return 'while ($_ = Elatin6::glob_)';
3314             }
3315              
3316 0         0 # while (glob(WILDCARD))
3317             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3318             return 'while ($_ = Elatin6::glob';
3319             }
3320 0         0  
  248         515  
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         1032  
  19         32  
3324 19         67 # subroutines of package Elatin6
  0         0  
3325 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         19  
3326 13         36 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3327 0         0 elsif (/\G \b Latin6::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         300  
3328 114         395 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3329 2         7 elsif (/\G \b Latin6::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin6::escape'; }
  0         0  
3330 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
3331 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::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 Latin6::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin6::index'; }
  2         6  
3335 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::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 Latin6::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin6::rindex'; }
  1         3  
3339 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::rindex'; }
  0         0  
3340 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::lc'; }
  1         2  
3341 1         4 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::lcfirst'; }
  0         0  
3342 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::uc'; }
  6         9  
3343             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::ucfirst'; }
3344             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::fc'; }
3345 6         16  
  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         4  
3368 2         7  
  2         3  
3369 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         59  
3370 36         102 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3371 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::chr'; }
  8         14  
3372 8         24 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 'Elatin6::glob'; }
  0         0  
3375 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::lc_'; }
  0         0  
3376 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::lcfirst_'; }
  0         0  
3377 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::uc_'; }
  0         0  
3378 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::ucfirst_'; }
  0         0  
3379             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::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 'Elatin6::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 'Elatin6::glob_'; }
  8         20  
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         28 # split
3391             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3392 87         284 $slash = 'm//';
3393 87         136  
3394 87         333 my $e = '';
3395             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3396             $e .= $1;
3397             }
3398 85 100       321  
  87 100       5842  
    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 'Elatin6::split' . $e; }
3401 2         10  
3402             # split scalar value
3403             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin6::split' . $e . e_string($1); }
3404 1         5  
3405 0         0 # split literal space
3406 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin6::split' . $e . qq {qq$1 $2}; }
3407 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3408 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3409 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3410 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3411 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3412 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin6::split' . $e . qq {q$1 $2}; }
3413 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3414 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3415 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3416 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3417 10         54 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3418             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin6::split' . $e . qq {' '}; }
3419             elsif (/\G " [ ] " /oxgc) { return 'Elatin6::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         439  
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       62 else {
  12 50       3363  
    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         77 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         457  
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       84 else {
  18 50       3803  
    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         115 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         111 elsif (/\G (\/) /oxgc) {
3517 44 50       187 my $regexp = '';
  381 50       1456  
    100          
    50          
3518 0         0 while (not /\G \z/oxgc) {
3519 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3520 44         193 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3521             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3522 337         665 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         53 # $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         7 else {
3545 3 50       8 my $e = '';
  3 50       389  
    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         13 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       5484  
3610 2180         4236 # 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         3127 else {
3623 2180 50       5458 my $e = '';
  2180 50       13560  
    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         3193 elsif (/\G (\{) /oxgc) { # qq { }
3646 2150         3557 my $qq_string = '';
3647 2150 100       4303 local $nest = 1;
  84006 50       266541  
    100          
    100          
    50          
3648 722         1691 while (not /\G \z/oxgc) {
3649 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1724  
3650             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3651 1153 100       2019 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5357  
3652 2150         5141 elsif (/\G (\}) /oxgc) {
3653             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3654 1153         2357 else { $qq_string .= $1; }
3655             }
3656 78828         177477 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         52 elsif (/\G (\<) /oxgc) { # qq < >
3680 30         60 my $qq_string = '';
3681 30 100       93 local $nest = 1;
  1166 50       4123  
    50          
    100          
    50          
3682 22         50 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         145  
3686 30         67 elsif (/\G (\>) /oxgc) {
3687             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3688 0         0 else { $qq_string .= $1; }
3689             }
3690 1114         2288 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       45 elsif (/\G \b (qw) \b /oxgc) {
3736 16         124 my $ope = $1;
3737             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3738             return e_qw($ope,$1,$3,$2);
3739 0         0 }
3740 16         53 else {
3741 16 50       406 my $e = '';
  16 50       110  
    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         75  
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       1174 # (and so on)
3793 410         1922  
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         778 else {
3806 410 50       1367 my $e = '';
  410 50       2099  
    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         708 elsif (/\G (\{) /oxgc) { # q { }
3830 404         655 my $q_string = '';
3831 404 50       1359 local $nest = 1;
  6770 50       26568  
    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       207 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1198  
3837 404         1176 elsif (/\G (\}) /oxgc) {
3838             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3839 107         234 else { $q_string .= $1; }
3840             }
3841 6152         11929 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         11 elsif (/\G (\<) /oxgc) { # q < >
3866 5         9 my $q_string = '';
3867 5 50       17 local $nest = 1;
  88 50       355  
    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         13  
3873 5         58 elsif (/\G (\>) /oxgc) {
3874             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3875 0         0 else { $q_string .= $1; }
3876             }
3877 83         161 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         2 my $delimiter = $1;
3885 1 50       3 my $q_string = '';
  14 50       57  
    100          
    50          
3886 0         0 while (not /\G \z/oxgc) {
3887 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3888 1         3 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         29 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       496 elsif (/\G \b (m) \b /oxgc) {
3901 209         1382 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         350 else {
3906 209 50       721 my $e = '';
  209 50       10724  
    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         30 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         618 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       337  
3932 97         1790 # $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         5 }
3936 96         425 else {
3937 96 50       292 my $e = '';
  96 50       12040  
    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         68 # $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         335 }
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         304 # 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         21 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         14 # 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         1966 elsif (/\G (?
4073 848 100       3381 my $q_string = '';
  8254 100       25361  
    100          
    50          
4074 4         9 while (not /\G \z/oxgc) {
4075 48         88 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4076 848         1778 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4077             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4078 7354         20887 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         3863 elsif (/\G (\") /oxgc) {
4085 1848 100       4814 my $qq_string = '';
  35409 100       118032  
    100          
    50          
4086 67         151 while (not /\G \z/oxgc) {
4087 12         27 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4088 1848         4050 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4089             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4090 33482         66500 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       5 my $qx_string = '';
  19 50       60  
    100          
    50          
4098 0         0 while (not /\G \z/oxgc) {
4099 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4100 1         4 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4101             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4102 18         38 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         1610 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4109 453 50       1367 my $regexp = '';
  4496 50       15972  
    100          
    50          
4110 0         0 while (not /\G \z/oxgc) {
4111 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4112 453         1642 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4113             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4114 4043         8753 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         15 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4139 6         11 $slash = 'm//';
4140             my $here_quote = $1;
4141             my $delimiter = $2;
4142 6 50       11  
4143 6         14 # get here document
4144 6         31 if ($here_script eq '') {
4145             $here_script = CORE::substr $_, pos $_;
4146 6 50       31 $here_script =~ s/.*?\n//oxm;
4147 6         58 }
4148 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4149 6         10 my $heredoc = $1;
4150 6         51 my $indent = $2;
4151 6         18 $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         24  
4171 3         7 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       6  
4176 3         6 # get here document
4177 3         14 if ($here_script eq '') {
4178             $here_script = CORE::substr $_, pos $_;
4179 3 50       24 $here_script =~ s/.*?\n//oxm;
4180 3         41 }
4181 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4182 3         4 my $heredoc = $1;
4183 3         38 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         15 }
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         21 # <<~"HEREDOC"
4195 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4196 6         10 $slash = 'm//';
4197             my $here_quote = $1;
4198             my $delimiter = $2;
4199 6 50       9  
4200 6         11 # get here document
4201 6         26 if ($here_script eq '') {
4202             $here_script = CORE::substr $_, pos $_;
4203 6 50       30 $here_script =~ s/.*?\n//oxm;
4204 6         63 }
4205 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4206 6         8 my $heredoc = $1;
4207 6         45 my $indent = $2;
4208 6         17 $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         13 }
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         21 # <<~HEREDOC
4219 3         6 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4220 3         6 $slash = 'm//';
4221             my $here_quote = $1;
4222             my $delimiter = $2;
4223 3 50       5  
4224 3         6 # get here document
4225 3         11 if ($here_script eq '') {
4226             $here_script = CORE::substr $_, pos $_;
4227 3 50       24 $here_script =~ s/.*?\n//oxm;
4228 3         36 }
4229 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4230 3         5 my $heredoc = $1;
4231 3         35 my $indent = $2;
4232 3         9 $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         11 # <<~`HEREDOC`
4243 6         12 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4244 6         13 $slash = 'm//';
4245             my $here_quote = $1;
4246             my $delimiter = $2;
4247 6 50       10  
4248 6         10 # get here document
4249 6         18 if ($here_script eq '') {
4250             $here_script = CORE::substr $_, pos $_;
4251 6 50       42 $here_script =~ s/.*?\n//oxm;
4252 6         57 }
4253 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4254 6         10 my $heredoc = $1;
4255 6         46 my $indent = $2;
4256 6         15 $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         21 # <<'HEREDOC'
4267 72         161 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4268 72         153 $slash = 'm//';
4269             my $here_quote = $1;
4270             my $delimiter = $2;
4271 72 50       136  
4272 72         157 # get here document
4273 72         371 if ($here_script eq '') {
4274             $here_script = CORE::substr $_, pos $_;
4275 72 50       401 $here_script =~ s/.*?\n//oxm;
4276 72         590 }
4277 72         388 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4278             push @heredoc, $1 . qq{\n$delimiter\n};
4279             push @heredoc_delimiter, $delimiter;
4280 72         117 }
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         368  
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         85 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4319 36         87 $slash = 'm//';
4320             my $here_quote = $1;
4321             my $delimiter = $2;
4322 36 50       60  
4323 36         95 # get here document
4324 36         268 if ($here_script eq '') {
4325             $here_script = CORE::substr $_, pos $_;
4326 36 50       200 $here_script =~ s/.*?\n//oxm;
4327 36         462 }
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         81 }
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         146 # <
4339 42         104 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4340 42         147 $slash = 'm//';
4341             my $here_quote = $1;
4342             my $delimiter = $2;
4343 42 50       89  
4344 42         1193 # get here document
4345 42         617 if ($here_script eq '') {
4346             $here_script = CORE::substr $_, pos $_;
4347 42 50       321 $here_script =~ s/.*?\n//oxm;
4348 42         609 }
4349 42         169 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         109 }
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         187 # <<`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         68 #
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 'Elatin6::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         1583 # 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         10229  
4423              
4424             ) /oxgc) { $slash = 'div'; return $1; }
4425              
4426             # yada-yada or triple-dot operator
4427             elsif (/\G (
4428 5081         23462 \.\.\.
  7         14  
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         17717  
4485              
4486             )) /oxgc) { $slash = 'm//'; return $1; }
4487 8868         47115  
  15137         33655  
4488             # other any character
4489             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4490              
4491 15137         83633 # system error
4492             else {
4493             die __FILE__, ": Oops, this shouldn't happen!\n";
4494             }
4495             }
4496              
4497 0     1786 0 0 # escape Latin-6 string
4498 1786         3975 sub e_string {
4499             my($string) = @_;
4500 1786         2708 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         2501 # (and so on)
4507              
4508             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4509 1786 100 66     15526  
4510 1786 50       22084 # without { ... }
4511 1769         4143 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4512             if ($string !~ /<
4513             return $string;
4514             }
4515             }
4516 1769         4476  
4517 17 50       74 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         14712  
4522 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin6::PREMATCH()]}
4523 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4524             $e_string .= q{Elatin6::PREMATCH()};
4525             $slash = 'div';
4526             }
4527              
4528 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin6::MATCH()]}
4529 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4530             $e_string .= q{Elatin6::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} --> @{[Elatin6::POSTMATCH()]}
4541 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4542             $e_string .= q{Elatin6::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         10 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         15 # $ @ % & * $ #
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         22 # $ @ # \ ' " / ? ( ) [ ] < >
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 Elatin6
  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 Latin6::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 Latin6::eval \b /oxgc) { $e_string .= 'eval Latin6::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 .= 'Elatin6::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 Latin6::index \b /oxgc) { $e_string .= 'Latin6::index'; $slash = 'm//'; }
  0         0  
4633 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin6::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 Latin6::rindex \b /oxgc) { $e_string .= 'Latin6::rindex'; $slash = 'm//'; }
  0         0  
4637 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin6::rindex'; $slash = 'm//'; }
  0         0  
4638 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::lc'; $slash = 'm//'; }
  0         0  
4639 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::lcfirst'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::uc'; $slash = 'm//'; }
  0         0  
4641             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::ucfirst'; $slash = 'm//'; }
4642             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::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 .= 'Elatin6::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 .= 'Elatin6::glob'; $slash = 'm//'; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin6::lc_'; $slash = 'm//'; }
  0         0  
4674 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin6::lcfirst_'; $slash = 'm//'; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin6::uc_'; $slash = 'm//'; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin6::ucfirst_'; $slash = 'm//'; }
  0         0  
4677             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin6::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 .= 'Elatin6::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 .= 'Elatin6::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 'Elatin6::split' . $e; }
4699 0         0  
  0         0  
4700             # split scalar value
4701             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin6::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 .= 'Elatin6::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4705 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4706 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4707 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4708 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin6::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 .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4710 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4711 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4712 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4713 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4714 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin6::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 .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4716             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {' '}; next E_STRING_LOOP; }
4717             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin6::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 .= 'Elatin6::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         38  
5145              
5146             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5147              
5148             # yada-yada or triple-dot operator
5149             elsif ($string =~ /\G (
5150 18         61 \.\.\.
  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         65  
5182              
5183             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5184 31         126  
5185             # other any character
5186             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5187              
5188 131         482 # 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 84 #
5200             sub character_class {
5201 1919 100       3778 my($char,$modifier) = @_;
5202 1919 100       3012  
5203 52         112 if ($char eq '.') {
5204             if ($modifier =~ /s/) {
5205             return '${Elatin6::dot_s}';
5206 17         40 }
5207             else {
5208             return '${Elatin6::dot}';
5209             }
5210 35         72 }
5211             else {
5212             return Elatin6::classic_character_class($char);
5213             }
5214             }
5215              
5216             #
5217             # escape capture ($1, $2, $3, ...)
5218             #
5219 1867     212 0 3229 sub e_capture {
5220              
5221             return join '', '${', $_[0], '}';
5222             }
5223              
5224             #
5225             # escape transliteration (tr/// or y///)
5226 212     3 0 1037 #
5227 3         20 sub e_tr {
5228 3   50     6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5229             my $e_tr = '';
5230 3         8 $modifier ||= '';
5231              
5232             $slash = 'div';
5233 3         4  
5234             # quote character class 1
5235             $charclass = q_tr($charclass);
5236 3         7  
5237             # quote character class 2
5238             $charclass2 = q_tr($charclass2);
5239 3 50       11  
5240 3 0       10 # /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         7 else {
5250             if ($variable eq '') {
5251             $e_tr = qq{Elatin6::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5252 2         8 }
5253             else {
5254             $e_tr = qq{Elatin6::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5255             }
5256             }
5257 1         5  
5258 3         5 # clear tr/// variable
5259             $tr_variable = '';
5260 3         2 $bind_operator = '';
5261              
5262             return $e_tr;
5263             }
5264              
5265             #
5266             # quote for escape transliteration (tr/// or y///)
5267 3     6 0 17 #
5268             sub q_tr {
5269             my($charclass) = @_;
5270 6 50       9  
    0          
    0          
    0          
    0          
    0          
5271 6         13 # quote character class
5272             if ($charclass !~ /'/oxms) {
5273             return e_q('', "'", "'", $charclass); # --> q' '
5274 6         11 }
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         3165 my($ope,$delimiter,$end_delimiter,$string) = @_;
5306              
5307 1264         1719 $slash = 'div';
5308              
5309             return join '', $ope, $delimiter, $string, $end_delimiter;
5310             }
5311              
5312             #
5313             # escape qq string (qq//, "", qx//, ``)
5314 1264     4110 0 5987 #
5315             sub e_qq {
5316 4110         9426 my($ope,$delimiter,$end_delimiter,$string) = @_;
5317              
5318 4110         8544 $slash = 'div';
5319 4110         6128  
5320             my $left_e = 0;
5321             my $right_e = 0;
5322 4110         4436  
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         144778 ))/oxmsg;
5339              
5340             for (my $i=0; $i <= $#char; $i++) {
5341 4110 50 33     14509  
    50 33        
    100          
    100          
    50          
5342 113973         393517 # "\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] = Elatin6::octchr($1);
5355             }
5356              
5357 1         3 # hexadecimal escape sequence
5358             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5359             $char[$i] = Elatin6::hexchr($1);
5360             }
5361              
5362 1         5 # \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         949921  
5377 0 50       0 # \u \l \U \L \F \Q \E
5378 484         1239 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] = '@{[Elatin6::ucfirst qq<';
5398             $left_e++;
5399 0         0 }
5400 0         0 elsif ($char[$i] eq '\l') {
5401             $char[$i] = '@{[Elatin6::lcfirst qq<';
5402             $left_e++;
5403 0         0 }
5404 0         0 elsif ($char[$i] eq '\U') {
5405             $char[$i] = '@{[Elatin6::uc qq<';
5406             $left_e++;
5407 0         0 }
5408 0         0 elsif ($char[$i] eq '\L') {
5409             $char[$i] = '@{[Elatin6::lc qq<';
5410             $left_e++;
5411 0         0 }
5412 24         32 elsif ($char[$i] eq '\F') {
5413             $char[$i] = '@{[Elatin6::fc qq<';
5414             $left_e++;
5415 24         38 }
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         31 if ($right_e < $left_e) {
5422             $char[$i] = '>]}';
5423             $right_e++;
5424 24         37 }
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         467 }
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} --> Elatin6::PREMATCH()
5477             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5478             $char[$i] = '@{[Elatin6::PREMATCH()]}';
5479             }
5480              
5481 44         117 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
5482             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5483             $char[$i] = '@{[Elatin6::MATCH()]}';
5484             }
5485              
5486 45         117 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
5487             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5488             $char[$i] = '@{[Elatin6::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         85 # ${ ... }
5496             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5497             $char[$i] = e_capture($1);
5498             }
5499             }
5500 0 50       0  
5501 4110         8530 # 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 42415 #
5511             sub e_qw {
5512 16         99 my($ope,$delimiter,$end_delimiter,$string) = @_;
5513              
5514             $slash = 'div';
5515 16         36  
  16         224  
5516 483 50       723 # 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         122 }
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         248 my($string) = @_;
5560              
5561 93         154 $slash = 'm//';
5562              
5563 93         346 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5564 93         165  
5565             my $left_e = 0;
5566             my $right_e = 0;
5567 93         179  
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         8032 ))/oxmsg;
5584              
5585             for (my $i=0; $i <= $#char; $i++) {
5586 93 50 33     445  
    50 33        
    100          
    100          
    50          
5587 3177         12441 # "\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] = Elatin6::octchr($1);
5600             }
5601              
5602 1         3 # hexadecimal escape sequence
5603             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5604             $char[$i] = Elatin6::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         32751  
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] = '@{[Elatin6::ucfirst qq<';
5623             $left_e++;
5624 0         0 }
5625 0         0 elsif ($char[$i] eq '\l') {
5626             $char[$i] = '@{[Elatin6::lcfirst qq<';
5627             $left_e++;
5628 0         0 }
5629 0         0 elsif ($char[$i] eq '\U') {
5630             $char[$i] = '@{[Elatin6::uc qq<';
5631             $left_e++;
5632 0         0 }
5633 0         0 elsif ($char[$i] eq '\L') {
5634             $char[$i] = '@{[Elatin6::lc qq<';
5635             $left_e++;
5636 0         0 }
5637 0         0 elsif ($char[$i] eq '\F') {
5638             $char[$i] = '@{[Elatin6::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} --> Elatin6::PREMATCH()
5702             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5703             $char[$i] = '@{[Elatin6::PREMATCH()]}';
5704             }
5705              
5706 8         45 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
5707             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5708             $char[$i] = '@{[Elatin6::MATCH()]}';
5709             }
5710              
5711 8         44 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
5712             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5713             $char[$i] = '@{[Elatin6::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         29 # ${ ... }
5721             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5722             $char[$i] = e_capture($1);
5723             }
5724             }
5725 0 50       0  
5726 93         339 # 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 740 #
5736 652   100     2702 sub e_qr {
5737             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5738 652         2814 $modifier ||= '';
5739 652 50       1159  
5740 652         2034 $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       1304  
    100          
5754 652         1953 # literal null string pattern
5755 8         11 if ($string eq '') {
5756 8         11 $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       36  
5764 2         6 # 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         14  
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       12 }
5802 642         1799  
5803             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5804             my $metachar = qr/[\@\\|[\]{^]/oxms;
5805 642         2334  
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       69858  
5831 642         2948 # 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         1205  
5861 642         789 my $left_e = 0;
5862             my $right_e = 0;
5863             for (my $i=0; $i <= $#char; $i++) {
5864 642 50 66     1520  
    50 66        
    100          
    100          
    100          
    100          
5865 1872         23012 # "\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] = Elatin6::octchr($1);
5878             }
5879              
5880 1         3 # hexadecimal escape sequence
5881             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5882             $char[$i] = Elatin6::hexchr($1);
5883             }
5884              
5885             # \b{...} --> b\{...}
5886             # \B{...} --> B\{...}
5887             # \N{CHARNAME} --> N\{CHARNAME}
5888             # \p{PROPERTY} --> p\{PROPERTY}
5889 1         5 # \P{PROPERTY} --> P\{PROPERTY}
5890             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5891             $char[$i] = $1 . '\\' . $2;
5892             }
5893              
5894 6         19 # \p, \P, \X --> p, P, X
5895             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5896             $char[$i] = $1;
5897 4 100 100     10 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5898              
5899             if (0) {
5900             }
5901 1872         5796  
5902 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5903 6         78 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       439 # (and so on)
5921 328         793  
5922             if ($char[$i+1] eq ']') {
5923             $i++;
5924 3         6 }
5925 328 50       473  
5926 1379         1946 while (1) {
5927             if (++$i > $#char) {
5928 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5929 1379         2005 }
5930             if ($char[$i] eq ']') {
5931             my $right = $i;
5932 328 100       379  
5933 328         1657 # [...]
  30         68  
5934             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5935             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin6::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5936 90         145 }
5937             else {
5938             splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
5939 298         1081 }
5940 328         582  
5941             $i = $left;
5942             last;
5943             }
5944             }
5945             }
5946              
5947 328         790 # open character class [^...]
5948             elsif ($char[$i] eq '[^') {
5949             my $left = $i;
5950              
5951             # [^] make die "Unmatched [] in regexp ...\n"
5952 74 100       107 # (and so on)
5953 74         173  
5954             if ($char[$i+1] eq ']') {
5955             $i++;
5956 4         6 }
5957 74 50       88  
5958 272         539 while (1) {
5959             if (++$i > $#char) {
5960 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5961 272         643 }
5962             if ($char[$i] eq ']') {
5963             my $right = $i;
5964 74 100       890  
5965 74         695 # [^...]
  30         80  
5966             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5967             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin6::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5968 90         189 }
5969             else {
5970             splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5971 44         793 }
5972 74         192  
5973             $i = $left;
5974             last;
5975             }
5976             }
5977             }
5978              
5979 74         210 # rewrite character class or escape character
5980             elsif (my $char = character_class($char[$i],$modifier)) {
5981             $char[$i] = $char;
5982             }
5983              
5984 139 50       472 # /i modifier
5985 20         32 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
5986             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
5987             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
5988 20         33 }
5989             else {
5990             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
5991             }
5992             }
5993              
5994 0 50       0 # \u \l \U \L \F \Q \E
5995 1         4 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] = '@{[Elatin6::ucfirst qq<';
6002             $left_e++;
6003 0         0 }
6004 0         0 elsif ($char[$i] eq '\l') {
6005             $char[$i] = '@{[Elatin6::lcfirst qq<';
6006             $left_e++;
6007 0         0 }
6008 1         3 elsif ($char[$i] eq '\U') {
6009             $char[$i] = '@{[Elatin6::uc qq<';
6010             $left_e++;
6011 1         4 }
6012 1         2 elsif ($char[$i] eq '\L') {
6013             $char[$i] = '@{[Elatin6::lc qq<';
6014             $left_e++;
6015 1         3 }
6016 18         32 elsif ($char[$i] eq '\F') {
6017             $char[$i] = '@{[Elatin6::fc qq<';
6018             $left_e++;
6019 18         37 }
6020 1         2 elsif ($char[$i] eq '\Q') {
6021             $char[$i] = '@{[CORE::quotemeta qq<';
6022             $left_e++;
6023 1 50       2 }
6024 21         38 elsif ($char[$i] eq '\E') {
6025 21         28 if ($right_e < $left_e) {
6026             $char[$i] = '>]}';
6027             $right_e++;
6028 21         42 }
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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6098             }
6099             }
6100              
6101 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
6102 8         22 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6103             if ($ignorecase) {
6104             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
6105 0         0 }
6106             else {
6107             $char[$i] = '@{[Elatin6::PREMATCH()]}';
6108             }
6109             }
6110              
6111 8 50       21 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
6112 8         21 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6113             if ($ignorecase) {
6114             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
6115 0         0 }
6116             else {
6117             $char[$i] = '@{[Elatin6::MATCH()]}';
6118             }
6119             }
6120              
6121 8 50       21 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
6122 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6123             if ($ignorecase) {
6124             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
6125 0         0 }
6126             else {
6127             $char[$i] = '@{[Elatin6::POSTMATCH()]}';
6128             }
6129             }
6130              
6131 6 0       19 # ${ 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] = '@{[Elatin6::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] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6143             }
6144             }
6145              
6146 0         0 # $scalar or @array
6147 21 100       51 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6148 21         112 $char[$i] = e_string($char[$i]);
6149             if ($ignorecase) {
6150             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6151             }
6152             }
6153              
6154 11 100 33     36 # 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         1050 }
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         502  
6173 642 50       1517 # make regexp string
6174 642 0 0     1351 $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         3563 }
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 5109 #
6194             sub qq_stuff {
6195             my($delimiter,$end_delimiter,$stuff) = @_;
6196 180 100       293  
6197 180         364 # scalar variable or array variable
6198             if ($stuff =~ /\A [\$\@] /oxms) {
6199             return $stuff;
6200             }
6201 100         333  
  80         401  
6202 80         217 # quote by delimiter
6203 80 50       209 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6204 80 50       146 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6205 80 50       123 next if $char eq $delimiter;
6206 80         142 next if $char eq $end_delimiter;
6207             if (not $octet{$char}) {
6208             return join '', 'qq', $char, $stuff, $char;
6209 80         564 }
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     47 sub e_qr_q {
6218             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6219 10         44 $modifier ||= '';
6220 10 50       15  
6221 10         21 $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       15  
    50          
6235 10         23 # literal null string pattern
6236 8         11 if ($string eq '') {
6237 8         10 $modifier =~ tr/bB//d;
6238             $modifier =~ tr/i//d;
6239             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6240             }
6241              
6242 8         35 # 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 10 #
6256             sub e_qr_qt {
6257 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6258              
6259             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6260 2         7  
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         63  
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         16  
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, Elatin6::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, Elatin6::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 (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6334             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6335             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6336 0         0 }
6337             else {
6338             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::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 14 #
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     281 sub e_s1 {
6392             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6393 76         331 $modifier ||= '';
6394 76 50       114  
6395 76         208 $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       134  
    50          
6409 76         248 # literal null string pattern
6410 8         9 if ($string eq '') {
6411 8         9 $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       51  
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         171  
6454             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6455             my $metachar = qr/[\@\\|[\]{^]/oxms;
6456 68         397  
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       16459  
6486 68         476 # 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         137  
6516             # count '('
6517 253         447 my $parens = grep { $_ eq '(' } @char;
6518 68         165  
6519 68         117 my $left_e = 0;
6520             my $right_e = 0;
6521             for (my $i=0; $i <= $#char; $i++) {
6522 68 50 33     222  
    50 33        
    100          
    100          
    50          
    50          
6523 195         1125 # "\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] = Elatin6::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] = Elatin6::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         818  
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       48 elsif ($char[$i] eq '[') {
6575 13         54 my $left = $i;
6576             if ($char[$i+1] eq ']') {
6577 0         0 $i++;
6578 13 50       18 }
6579 58         84 while (1) {
6580             if (++$i > $#char) {
6581 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6582 58         126 }
6583             if ($char[$i] eq ']') {
6584             my $right = $i;
6585 13 50       21  
6586 13         77 # [...]
  0         0  
6587             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6588             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin6::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, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
6592 13         58 }
6593 13         27  
6594             $i = $left;
6595             last;
6596             }
6597             }
6598             }
6599              
6600 13         35 # 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{@{[Elatin6::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, Elatin6::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       14 # /i modifier
6633 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6634             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6635             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6636 3         5 }
6637             else {
6638             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::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] = '@{[Elatin6::ucfirst qq<';
6650             $left_e++;
6651 0         0 }
6652 0         0 elsif ($char[$i] eq '\l') {
6653             $char[$i] = '@{[Elatin6::lcfirst qq<';
6654             $left_e++;
6655 0         0 }
6656 0         0 elsif ($char[$i] eq '\U') {
6657             $char[$i] = '@{[Elatin6::uc qq<';
6658             $left_e++;
6659 0         0 }
6660 0         0 elsif ($char[$i] eq '\L') {
6661             $char[$i] = '@{[Elatin6::lc qq<';
6662             $left_e++;
6663 0         0 }
6664 0         0 elsif ($char[$i] eq '\F') {
6665             $char[$i] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6776             }
6777             }
6778              
6779 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
6780 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6781             if ($ignorecase) {
6782             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
6783 0         0 }
6784             else {
6785             $char[$i] = '@{[Elatin6::PREMATCH()]}';
6786             }
6787             }
6788              
6789 4 50       15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
6790 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6791             if ($ignorecase) {
6792             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
6793 0         0 }
6794             else {
6795             $char[$i] = '@{[Elatin6::MATCH()]}';
6796             }
6797             }
6798              
6799 4 50       15 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
6800 3         11 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6801             if ($ignorecase) {
6802             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
6803 0         0 }
6804             else {
6805             $char[$i] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6821             }
6822             }
6823              
6824 0         0 # $scalar or @array
6825 4 50       23 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6826 4         19 $char[$i] = e_string($char[$i]);
6827             if ($ignorecase) {
6828             $char[$i] = '@{[Elatin6::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         66 }
6836             else {
6837             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6838             }
6839             }
6840             }
6841 13         62  
6842 68         156 # make regexp string
6843 68 50       123 my $prematch = '';
6844 68         175 $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 737 #
6854 21   100     51 sub e_s1_q {
6855             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6856 21         66 $modifier ||= '';
6857 21 50       31  
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       48  
    50          
6872 21         63 # literal null string pattern
6873 8         20 if ($string eq '') {
6874 8         13 $modifier =~ tr/bB//d;
6875             $modifier =~ tr/i//d;
6876             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6877             }
6878              
6879 8         48 # 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 35 #
6893             sub e_s1_qt {
6894 13 50       31 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6895              
6896             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6897 13         27  
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         231  
6910 13 50 33     46 # 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, Elatin6::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, Elatin6::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       14 # /i modifier
6970 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6971             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6972             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6973 0         0 }
6974             else {
6975             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::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         23  
6989 13         18 $modifier =~ tr/i//d;
6990 13         17 $delimiter = '/';
6991 13         19 $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 98 #
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         46 my($ope,$delimiter,$end_delimiter,$string) = @_;
7031              
7032 16         23 $slash = 'div';
7033 16         97  
7034 16 100       47 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7035             for (my $i=0; $i <= $#char; $i++) {
7036             if (0) {
7037             }
7038 9         38  
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         17 }
7048              
7049             return join '', $ope, $delimiter, @char, $end_delimiter;
7050             }
7051              
7052             #
7053             # escape regexp (s/here/and here/modifier)
7054 16     97 0 54 #
7055 97   100     1000 sub e_sub {
7056             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7057 97         398 $modifier ||= '';
7058 97 50       183  
7059 97         289 $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         570  
7071 36         51 if ($variable eq '') {
7072             $variable = '$_';
7073             $bind_operator = ' =~ ';
7074 36         47 }
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         167 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7092 97         152  
7093             my $e_modifier = $modifier =~ tr/e//d;
7094 97         136 my $r_modifier = $modifier =~ tr/r//d;
7095 97 50       280  
7096 97         259 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         245  
7103             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7104             $variable_basename =~ s/ \s+ \z//oxms;
7105 97         177  
7106 97 100       154 # quote replacement string
7107 97         240 my $e_replacement = '';
7108 17         32 if ($e_modifier >= 1) {
7109             $e_replacement = e_qq('', '', '', $replacement);
7110             $e_modifier--;
7111 17 100       25 }
7112 80         214 else {
7113             if ($delimiter2 eq "'") {
7114             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7115 16         39 }
7116             else {
7117             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7118             }
7119 64         172 }
7120              
7121             my $sub = '';
7122 97 100       176  
7123 97 100       207 # with /r
7124             if ($r_modifier) {
7125             if (0) {
7126             }
7127 8         17  
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             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 5
7141             );
7142             }
7143              
7144             # s///r
7145 4         16 else {
7146              
7147 4 50       4 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 $Elatin6::re_r=%s; %s"%s$Elatin6::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             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 5
7160             $prematch, # 6
7161             $variable, # 7
7162             );
7163             }
7164 4 50       18  
7165 8         22 # $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         217  
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             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 5
7189             $variable, # 6
7190             $variable, # 7
7191             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7192             );
7193             }
7194              
7195             # s///
7196 22         83 else {
7197              
7198 67 100       123 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 $Elatin6::re_r=%s; %s%s="%s$Elatin6::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 $Elatin6::re_r=%s; %s%s="%s$Elatin6::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             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 6
7218             $variable, # 7
7219             $prematch, # 8
7220             );
7221             }
7222             }
7223 67 50       387  
7224 97         271 # (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         154 # clear s/// variable
7230             $sub_variable = '';
7231 97         130 $bind_operator = '';
7232              
7233             return $sub;
7234             }
7235              
7236             #
7237             # escape regexp of split qr//
7238 97     74 0 640 #
7239 74   100     336 sub e_split {
7240             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7241 74         362 $modifier ||= '';
7242 74 50       121  
7243 74         181 $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       114  
7257 74         162 # /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         161  
7262             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7263             my $metachar = qr/[\@\\|[\]{^]/oxms;
7264 74         258  
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         9233 ))/oxmsg;
7289 74         242  
7290 74         114 my $left_e = 0;
7291             my $right_e = 0;
7292             for (my $i=0; $i <= $#char; $i++) {
7293 74 50 33     1505  
    50 33        
    100          
    100          
    50          
    50          
7294 249         1248 # "\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] = Elatin6::octchr($1);
7307             }
7308              
7309 1         3 # hexadecimal escape sequence
7310             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7311             $char[$i] = Elatin6::hexchr($1);
7312             }
7313              
7314             # \b{...} --> b\{...}
7315             # \B{...} --> B\{...}
7316             # \N{CHARNAME} --> N\{CHARNAME}
7317             # \p{PROPERTY} --> p\{PROPERTY}
7318 1         5 # \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         802  
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       5 elsif ($char[$i] eq '[') {
7346 3         8 my $left = $i;
7347             if ($char[$i+1] eq ']') {
7348 0         0 $i++;
7349 3 50       3 }
7350 7         19 while (1) {
7351             if (++$i > $#char) {
7352 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7353 7         11 }
7354             if ($char[$i] eq ']') {
7355             my $right = $i;
7356 3 50       4  
7357 3         13 # [...]
  0         0  
7358             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7359             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin6::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, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
7363 3         10 }
7364 3         5  
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{@{[Elatin6::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, Elatin6::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         2 # split(m/^/) --> split(m/^/m)
7416             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7417             $modifier .= 'm';
7418             }
7419              
7420 7 0       22 # /i modifier
7421 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
7422             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
7423             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
7424 0         0 }
7425             else {
7426             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::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] = '@{[Elatin6::ucfirst qq<';
7438             $left_e++;
7439 0         0 }
7440 0         0 elsif ($char[$i] eq '\l') {
7441             $char[$i] = '@{[Elatin6::lcfirst qq<';
7442             $left_e++;
7443 0         0 }
7444 0         0 elsif ($char[$i] eq '\U') {
7445             $char[$i] = '@{[Elatin6::uc qq<';
7446             $left_e++;
7447 0         0 }
7448 0         0 elsif ($char[$i] eq '\L') {
7449             $char[$i] = '@{[Elatin6::lc qq<';
7450             $left_e++;
7451 0         0 }
7452 0         0 elsif ($char[$i] eq '\F') {
7453             $char[$i] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::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] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7534             }
7535             }
7536              
7537 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
7538 12         34 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7539             if ($ignorecase) {
7540             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
7541 0         0 }
7542             else {
7543             $char[$i] = '@{[Elatin6::PREMATCH()]}';
7544             }
7545             }
7546              
7547 12 50       49 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
7548 12         31 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7549             if ($ignorecase) {
7550             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
7551 0         0 }
7552             else {
7553             $char[$i] = '@{[Elatin6::MATCH()]}';
7554             }
7555             }
7556              
7557 12 50       50 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
7558 9         29 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7559             if ($ignorecase) {
7560             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
7561 0         0 }
7562             else {
7563             $char[$i] = '@{[Elatin6::POSTMATCH()]}';
7564             }
7565             }
7566              
7567 9 0       40 # ${ 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] = '@{[Elatin6::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] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7579             }
7580             }
7581              
7582 0         0 # $scalar or @array
7583 3 50       9 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7584 3         12 $char[$i] = e_string($char[$i]);
7585             if ($ignorecase) {
7586             $char[$i] = '@{[Elatin6::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         6 }
7594             else {
7595             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7596             }
7597             }
7598             }
7599 0         0  
7600 74 50       286 # make regexp string
7601 74         290 $modifier =~ tr/i//d;
7602             if ($left_e > $right_e) {
7603 0         0 return join '', 'Elatin6::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7604             }
7605             return join '', 'Elatin6::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7606             }
7607              
7608             #
7609             # escape regexp of split qr''
7610 74     0 0 711 #
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, Elatin6::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, Elatin6::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 (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
7708             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
7709             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
7710 0           }
7711             else {
7712             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::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 '', 'Elatin6::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__