File Coverage

blib/lib/Elatin6.pm
Criterion Covered Total %
statement 905 3194 28.3
branch 968 2740 35.3
condition 98 355 27.6
subroutine 52 110 47.2
pod 7 74 9.4
total 2030 6473 31.3


line stmt bran cond sub pod time code
1             package Elatin6;
2 204     204   1515 use strict;
  204         343  
  204         5990  
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   3882 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         580  
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   1030 use vars qw($VERSION);
  204         438  
  204         30733  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1542 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         352 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         46479 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   13863 CORE::eval q{
  204     204   1339  
  204     46   374  
  204         29227  
  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       105000 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 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     0 0 0 my($name) = @_;
73              
74 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
75 0         0 return $name;
76             }
77             elsif (Elatin6::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Elatin6::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 0         0 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 0   0 0 0 if (defined $_[1]) {
112 204     204   2869 no strict qw(refs);
  204         437  
  204         15203  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1239 no strict qw(refs);
  204     0   363  
  204         39171  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x00-\xFF]};
148 204     204   1424 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         438  
  204         12706  
149 204     204   1387 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         384  
  204         463273  
150              
151             #
152             # Latin-6 character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # Latin-6 case conversion
158             #
159             my %lc = ();
160             @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)} =
161             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);
162             my %uc = ();
163             @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)} =
164             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);
165             my %fc = ();
166             @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)} =
167             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Elatin6 \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177              
178             %lc = (%lc,
179             "\xA1" => "\xB1", # LATIN LETTER A WITH OGONEK
180             "\xA2" => "\xB2", # LATIN LETTER E WITH MACRON
181             "\xA3" => "\xB3", # LATIN LETTER G WITH CEDILLA
182             "\xA4" => "\xB4", # LATIN LETTER I WITH MACRON
183             "\xA5" => "\xB5", # LATIN LETTER I WITH TILDE
184             "\xA6" => "\xB6", # LATIN LETTER K WITH CEDILLA
185             "\xA8" => "\xB8", # LATIN LETTER L WITH CEDILLA
186             "\xA9" => "\xB9", # LATIN LETTER D WITH STROKE
187             "\xAA" => "\xBA", # LATIN LETTER S WITH CARON
188             "\xAB" => "\xBB", # LATIN LETTER T WITH STROKE
189             "\xAC" => "\xBC", # LATIN LETTER Z WITH CARON
190             "\xAE" => "\xBE", # LATIN LETTER U WITH MACRON
191             "\xAF" => "\xBF", # LATIN LETTER ENG
192             "\xC0" => "\xE0", # LATIN LETTER A WITH MACRON
193             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
194             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
195             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
196             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
197             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
198             "\xC6" => "\xE6", # LATIN LETTER AE
199             "\xC7" => "\xE7", # LATIN LETTER I WITH OGONEK
200             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
201             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
202             "\xCA" => "\xEA", # LATIN LETTER E WITH OGONEK
203             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
204             "\xCC" => "\xEC", # LATIN LETTER E WITH DOT ABOVE
205             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
206             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
207             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
208             "\xD0" => "\xF0", # LATIN LETTER ETH (Icelandic)
209             "\xD1" => "\xF1", # LATIN LETTER N WITH CEDILLA
210             "\xD2" => "\xF2", # LATIN LETTER O WITH MACRON
211             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
212             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
213             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
214             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
215             "\xD7" => "\xF7", # LATIN LETTER U WITH TILDE
216             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
217             "\xD9" => "\xF9", # LATIN LETTER U WITH OGONEK
218             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
219             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
220             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
221             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
222             "\xDE" => "\xFE", # LATIN LETTER THORN (Icelandic)
223             );
224              
225             %uc = (%uc,
226             "\xB1" => "\xA1", # LATIN LETTER A WITH OGONEK
227             "\xB2" => "\xA2", # LATIN LETTER E WITH MACRON
228             "\xB3" => "\xA3", # LATIN LETTER G WITH CEDILLA
229             "\xB4" => "\xA4", # LATIN LETTER I WITH MACRON
230             "\xB5" => "\xA5", # LATIN LETTER I WITH TILDE
231             "\xB6" => "\xA6", # LATIN LETTER K WITH CEDILLA
232             "\xB8" => "\xA8", # LATIN LETTER L WITH CEDILLA
233             "\xB9" => "\xA9", # LATIN LETTER D WITH STROKE
234             "\xBA" => "\xAA", # LATIN LETTER S WITH CARON
235             "\xBB" => "\xAB", # LATIN LETTER T WITH STROKE
236             "\xBC" => "\xAC", # LATIN LETTER Z WITH CARON
237             "\xBE" => "\xAE", # LATIN LETTER U WITH MACRON
238             "\xBF" => "\xAF", # LATIN LETTER ENG
239             "\xE0" => "\xC0", # LATIN LETTER A WITH MACRON
240             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
241             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
242             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
243             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
244             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
245             "\xE6" => "\xC6", # LATIN LETTER AE
246             "\xE7" => "\xC7", # LATIN LETTER I WITH OGONEK
247             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
248             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
249             "\xEA" => "\xCA", # LATIN LETTER E WITH OGONEK
250             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
251             "\xEC" => "\xCC", # LATIN LETTER E WITH DOT ABOVE
252             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
253             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
254             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
255             "\xF0" => "\xD0", # LATIN LETTER ETH (Icelandic)
256             "\xF1" => "\xD1", # LATIN LETTER N WITH CEDILLA
257             "\xF2" => "\xD2", # LATIN LETTER O WITH MACRON
258             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
259             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
260             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
261             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
262             "\xF7" => "\xD7", # LATIN LETTER U WITH TILDE
263             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
264             "\xF9" => "\xD9", # LATIN LETTER U WITH OGONEK
265             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
266             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
267             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
268             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
269             "\xFE" => "\xDE", # LATIN LETTER THORN (Icelandic)
270             );
271              
272             %fc = (%fc,
273             "\xA1" => "\xB1", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
274             "\xA2" => "\xB2", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
275             "\xA3" => "\xB3", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
276             "\xA4" => "\xB4", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
277             "\xA5" => "\xB5", # LATIN CAPITAL LETTER I WITH TILDE --> LATIN SMALL LETTER I WITH TILDE
278             "\xA6" => "\xB6", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
279             "\xA8" => "\xB8", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
280             "\xA9" => "\xB9", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
281             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
282             "\xAB" => "\xBB", # LATIN CAPITAL LETTER T WITH STROKE --> LATIN SMALL LETTER T WITH STROKE
283             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
284             "\xAE" => "\xBE", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
285             "\xAF" => "\xBF", # LATIN CAPITAL LETTER ENG --> LATIN SMALL LETTER ENG
286             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
287             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
288             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
289             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
290             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
291             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
292             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
293             "\xC7" => "\xE7", # LATIN CAPITAL LETTER I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
294             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
295             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
296             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
297             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
298             "\xCC" => "\xEC", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
299             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
300             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
301             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
302             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
303             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
304             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
305             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
306             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
307             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
308             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
309             "\xD7" => "\xF7", # LATIN CAPITAL LETTER U WITH TILDE --> LATIN SMALL LETTER U WITH TILDE
310             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
311             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
312             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
313             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
314             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
315             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
316             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
317             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
318             );
319             }
320              
321             else {
322             croak "Don't know my package name '@{[__PACKAGE__]}'";
323             }
324              
325             #
326             # @ARGV wildcard globbing
327             #
328             sub import {
329              
330 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
331 0         0 my @argv = ();
332 0         0 for (@ARGV) {
333              
334             # has space
335 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
336 0 0       0 if (my @glob = Elatin6::glob(qq{"$_"})) {
337 0         0 push @argv, @glob;
338             }
339             else {
340 0         0 push @argv, $_;
341             }
342             }
343              
344             # has wildcard metachar
345             elsif (/\A (?:$q_char)*? [*?] /oxms) {
346 0 0       0 if (my @glob = Elatin6::glob($_)) {
347 0         0 push @argv, @glob;
348             }
349             else {
350 0         0 push @argv, $_;
351             }
352             }
353              
354             # no wildcard globbing
355             else {
356 0         0 push @argv, $_;
357             }
358             }
359 0         0 @ARGV = @argv;
360             }
361              
362 0         0 *Char::ord = \&Latin6::ord;
363 0         0 *Char::ord_ = \&Latin6::ord_;
364 0         0 *Char::reverse = \&Latin6::reverse;
365 0         0 *Char::getc = \&Latin6::getc;
366 0         0 *Char::length = \&Latin6::length;
367 0         0 *Char::substr = \&Latin6::substr;
368 0         0 *Char::index = \&Latin6::index;
369 0         0 *Char::rindex = \&Latin6::rindex;
370 0         0 *Char::eval = \&Latin6::eval;
371 0         0 *Char::escape = \&Latin6::escape;
372 0         0 *Char::escape_token = \&Latin6::escape_token;
373 0         0 *Char::escape_script = \&Latin6::escape_script;
374             }
375              
376             # P.230 Care with Prototypes
377             # in Chapter 6: Subroutines
378             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
379             #
380             # If you aren't careful, you can get yourself into trouble with prototypes.
381             # But if you are careful, you can do a lot of neat things with them. This is
382             # all very powerful, of course, and should only be used in moderation to make
383             # the world a better place.
384              
385             # P.332 Care with Prototypes
386             # in Chapter 7: Subroutines
387             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
388             #
389             # If you aren't careful, you can get yourself into trouble with prototypes.
390             # But if you are careful, you can do a lot of neat things with them. This is
391             # all very powerful, of course, and should only be used in moderation to make
392             # the world a better place.
393              
394             #
395             # Prototypes of subroutines
396             #
397       0     sub unimport {}
398             sub Elatin6::split(;$$$);
399             sub Elatin6::tr($$$$;$);
400             sub Elatin6::chop(@);
401             sub Elatin6::index($$;$);
402             sub Elatin6::rindex($$;$);
403             sub Elatin6::lcfirst(@);
404             sub Elatin6::lcfirst_();
405             sub Elatin6::lc(@);
406             sub Elatin6::lc_();
407             sub Elatin6::ucfirst(@);
408             sub Elatin6::ucfirst_();
409             sub Elatin6::uc(@);
410             sub Elatin6::uc_();
411             sub Elatin6::fc(@);
412             sub Elatin6::fc_();
413             sub Elatin6::ignorecase;
414             sub Elatin6::classic_character_class;
415             sub Elatin6::capture;
416             sub Elatin6::chr(;$);
417             sub Elatin6::chr_();
418             sub Elatin6::glob($);
419             sub Elatin6::glob_();
420              
421             sub Latin6::ord(;$);
422             sub Latin6::ord_();
423             sub Latin6::reverse(@);
424             sub Latin6::getc(;*@);
425             sub Latin6::length(;$);
426             sub Latin6::substr($$;$$);
427             sub Latin6::index($$;$);
428             sub Latin6::rindex($$;$);
429             sub Latin6::escape(;$);
430              
431             #
432             # Regexp work
433             #
434 204         16124 use vars qw(
435             $re_a
436             $re_t
437             $re_n
438             $re_r
439 204     204   1616 );
  204         403  
440              
441             #
442             # Character class
443             #
444 204         2259908 use vars qw(
445             $dot
446             $dot_s
447             $eD
448             $eS
449             $eW
450             $eH
451             $eV
452             $eR
453             $eN
454             $not_alnum
455             $not_alpha
456             $not_ascii
457             $not_blank
458             $not_cntrl
459             $not_digit
460             $not_graph
461             $not_lower
462             $not_lower_i
463             $not_print
464             $not_punct
465             $not_space
466             $not_upper
467             $not_upper_i
468             $not_word
469             $not_xdigit
470             $eb
471             $eB
472 204     204   1454 );
  204         371  
473              
474             ${Elatin6::dot} = qr{(?>[^\x0A])};
475             ${Elatin6::dot_s} = qr{(?>[\x00-\xFF])};
476             ${Elatin6::eD} = qr{(?>[^0-9])};
477              
478             # Vertical tabs are now whitespace
479             # \s in a regex now matches a vertical tab in all circumstances.
480             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
481             # ${Elatin6::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
482             # ${Elatin6::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
483             ${Elatin6::eS} = qr{(?>[^\s])};
484              
485             ${Elatin6::eW} = qr{(?>[^0-9A-Z_a-z])};
486             ${Elatin6::eH} = qr{(?>[^\x09\x20])};
487             ${Elatin6::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
488             ${Elatin6::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
489             ${Elatin6::eN} = qr{(?>[^\x0A])};
490             ${Elatin6::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
491             ${Elatin6::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
492             ${Elatin6::not_ascii} = qr{(?>[^\x00-\x7F])};
493             ${Elatin6::not_blank} = qr{(?>[^\x09\x20])};
494             ${Elatin6::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
495             ${Elatin6::not_digit} = qr{(?>[^\x30-\x39])};
496             ${Elatin6::not_graph} = qr{(?>[^\x21-\x7F])};
497             ${Elatin6::not_lower} = qr{(?>[^\x61-\x7A])};
498             ${Elatin6::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
499             # ${Elatin6::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
500             ${Elatin6::not_print} = qr{(?>[^\x20-\x7F])};
501             ${Elatin6::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
502             ${Elatin6::not_space} = qr{(?>[^\s\x0B])};
503             ${Elatin6::not_upper} = qr{(?>[^\x41-\x5A])};
504             ${Elatin6::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
505             # ${Elatin6::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
506             ${Elatin6::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
507             ${Elatin6::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
508             ${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))};
509             ${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]))};
510              
511             # avoid: Name "Elatin6::foo" used only once: possible typo at here.
512             ${Elatin6::dot} = ${Elatin6::dot};
513             ${Elatin6::dot_s} = ${Elatin6::dot_s};
514             ${Elatin6::eD} = ${Elatin6::eD};
515             ${Elatin6::eS} = ${Elatin6::eS};
516             ${Elatin6::eW} = ${Elatin6::eW};
517             ${Elatin6::eH} = ${Elatin6::eH};
518             ${Elatin6::eV} = ${Elatin6::eV};
519             ${Elatin6::eR} = ${Elatin6::eR};
520             ${Elatin6::eN} = ${Elatin6::eN};
521             ${Elatin6::not_alnum} = ${Elatin6::not_alnum};
522             ${Elatin6::not_alpha} = ${Elatin6::not_alpha};
523             ${Elatin6::not_ascii} = ${Elatin6::not_ascii};
524             ${Elatin6::not_blank} = ${Elatin6::not_blank};
525             ${Elatin6::not_cntrl} = ${Elatin6::not_cntrl};
526             ${Elatin6::not_digit} = ${Elatin6::not_digit};
527             ${Elatin6::not_graph} = ${Elatin6::not_graph};
528             ${Elatin6::not_lower} = ${Elatin6::not_lower};
529             ${Elatin6::not_lower_i} = ${Elatin6::not_lower_i};
530             ${Elatin6::not_print} = ${Elatin6::not_print};
531             ${Elatin6::not_punct} = ${Elatin6::not_punct};
532             ${Elatin6::not_space} = ${Elatin6::not_space};
533             ${Elatin6::not_upper} = ${Elatin6::not_upper};
534             ${Elatin6::not_upper_i} = ${Elatin6::not_upper_i};
535             ${Elatin6::not_word} = ${Elatin6::not_word};
536             ${Elatin6::not_xdigit} = ${Elatin6::not_xdigit};
537             ${Elatin6::eb} = ${Elatin6::eb};
538             ${Elatin6::eB} = ${Elatin6::eB};
539              
540             #
541             # Latin-6 split
542             #
543             sub Elatin6::split(;$$$) {
544              
545             # P.794 29.2.161. split
546             # in Chapter 29: Functions
547             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
548              
549             # P.951 split
550             # in Chapter 27: Functions
551             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
552              
553 0     0 0 0 my $pattern = $_[0];
554 0         0 my $string = $_[1];
555 0         0 my $limit = $_[2];
556              
557             # if $pattern is also omitted or is the literal space, " "
558 0 0       0 if (not defined $pattern) {
559 0         0 $pattern = ' ';
560             }
561              
562             # if $string is omitted, the function splits the $_ string
563 0 0       0 if (not defined $string) {
564 0 0       0 if (defined $_) {
565 0         0 $string = $_;
566             }
567             else {
568 0         0 $string = '';
569             }
570             }
571              
572 0         0 my @split = ();
573              
574             # when string is empty
575 0 0       0 if ($string eq '') {
    0          
576              
577             # resulting list value in list context
578 0 0       0 if (wantarray) {
579 0         0 return @split;
580             }
581              
582             # count of substrings in scalar context
583             else {
584 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
585 0         0 @_ = @split;
586 0         0 return scalar @_;
587             }
588             }
589              
590             # split's first argument is more consistently interpreted
591             #
592             # After some changes earlier in v5.17, split's behavior has been simplified:
593             # if the PATTERN argument evaluates to a string containing one space, it is
594             # treated the way that a literal string containing one space once was.
595             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
596              
597             # if $pattern is also omitted or is the literal space, " ", the function splits
598             # on whitespace, /\s+/, after skipping any leading whitespace
599             # (and so on)
600              
601             elsif ($pattern eq ' ') {
602 0 0       0 if (not defined $limit) {
603 0         0 return CORE::split(' ', $string);
604             }
605             else {
606 0         0 return CORE::split(' ', $string, $limit);
607             }
608             }
609              
610             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
611 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
612              
613             # a pattern capable of matching either the null string or something longer than the
614             # null string will split the value of $string into separate characters wherever it
615             # matches the null string between characters
616             # (and so on)
617              
618 0 0       0 if ('' =~ / \A $pattern \z /xms) {
619 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
620 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
621              
622             # P.1024 Appendix W.10 Multibyte Processing
623             # of ISBN 1-56592-224-7 CJKV Information Processing
624             # (and so on)
625              
626             # the //m modifier is assumed when you split on the pattern /^/
627             # (and so on)
628              
629             # V
630 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
631              
632             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
633             # is included in the resulting list, interspersed with the fields that are ordinarily returned
634             # (and so on)
635              
636 0         0 local $@;
637 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
638 0         0 push @split, CORE::eval('$' . $digit);
639             }
640             }
641             }
642              
643             else {
644 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
645              
646             # V
647 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
648 0         0 local $@;
649 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
650 0         0 push @split, CORE::eval('$' . $digit);
651             }
652             }
653             }
654             }
655              
656             elsif ($limit > 0) {
657 0 0       0 if ('' =~ / \A $pattern \z /xms) {
658 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
659 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
660              
661             # V
662 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
663 0         0 local $@;
664 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
665 0         0 push @split, CORE::eval('$' . $digit);
666             }
667             }
668             }
669             }
670             else {
671 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
672 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
673              
674             # V
675 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
676 0         0 local $@;
677 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
678 0         0 push @split, CORE::eval('$' . $digit);
679             }
680             }
681             }
682             }
683             }
684              
685 0 0       0 if (CORE::length($string) > 0) {
686 0         0 push @split, $string;
687             }
688              
689             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
690 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
691 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
692 0         0 pop @split;
693             }
694             }
695              
696             # resulting list value in list context
697 0 0       0 if (wantarray) {
698 0         0 return @split;
699             }
700              
701             # count of substrings in scalar context
702             else {
703 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
704 0         0 @_ = @split;
705 0         0 return scalar @_;
706             }
707             }
708              
709             #
710             # get last subexpression offsets
711             #
712             sub _last_subexpression_offsets {
713 0     0   0 my $pattern = $_[0];
714              
715             # remove comment
716 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
717              
718 0         0 my $modifier = '';
719 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
720 0         0 $modifier = $1;
721 0         0 $modifier =~ s/-[A-Za-z]*//;
722             }
723              
724             # with /x modifier
725 0         0 my @char = ();
726 0 0       0 if ($modifier =~ /x/oxms) {
727 0         0 @char = $pattern =~ /\G((?>
728             [^\\\#\[\(] |
729             \\ $q_char |
730             \# (?>[^\n]*) $ |
731             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
732             \(\? |
733             $q_char
734             ))/oxmsg;
735             }
736              
737             # without /x modifier
738             else {
739 0         0 @char = $pattern =~ /\G((?>
740             [^\\\[\(] |
741             \\ $q_char |
742             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
743             \(\? |
744             $q_char
745             ))/oxmsg;
746             }
747              
748 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
749             }
750              
751             #
752             # Latin-6 transliteration (tr///)
753             #
754             sub Elatin6::tr($$$$;$) {
755              
756 0     0 0 0 my $bind_operator = $_[1];
757 0         0 my $searchlist = $_[2];
758 0         0 my $replacementlist = $_[3];
759 0   0     0 my $modifier = $_[4] || '';
760              
761 0 0       0 if ($modifier =~ /r/oxms) {
762 0 0       0 if ($bind_operator =~ / !~ /oxms) {
763 0         0 croak "Using !~ with tr///r doesn't make sense";
764             }
765             }
766              
767 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
768 0         0 my @searchlist = _charlist_tr($searchlist);
769 0         0 my @replacementlist = _charlist_tr($replacementlist);
770              
771 0         0 my %tr = ();
772 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
773 0 0       0 if (not exists $tr{$searchlist[$i]}) {
774 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
775 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
776             }
777             elsif ($modifier =~ /d/oxms) {
778 0         0 $tr{$searchlist[$i]} = '';
779             }
780             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
781 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
782             }
783             else {
784 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
785             }
786             }
787             }
788              
789 0         0 my $tr = 0;
790 0         0 my $replaced = '';
791 0 0       0 if ($modifier =~ /c/oxms) {
792 0         0 while (defined(my $char = shift @char)) {
793 0 0       0 if (not exists $tr{$char}) {
794 0 0       0 if (defined $replacementlist[0]) {
795 0         0 $replaced .= $replacementlist[0];
796             }
797 0         0 $tr++;
798 0 0       0 if ($modifier =~ /s/oxms) {
799 0   0     0 while (@char and (not exists $tr{$char[0]})) {
800 0         0 shift @char;
801 0         0 $tr++;
802             }
803             }
804             }
805             else {
806 0         0 $replaced .= $char;
807             }
808             }
809             }
810             else {
811 0         0 while (defined(my $char = shift @char)) {
812 0 0       0 if (exists $tr{$char}) {
813 0         0 $replaced .= $tr{$char};
814 0         0 $tr++;
815 0 0       0 if ($modifier =~ /s/oxms) {
816 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
817 0         0 shift @char;
818 0         0 $tr++;
819             }
820             }
821             }
822             else {
823 0         0 $replaced .= $char;
824             }
825             }
826             }
827              
828 0 0       0 if ($modifier =~ /r/oxms) {
829 0         0 return $replaced;
830             }
831             else {
832 0         0 $_[0] = $replaced;
833 0 0       0 if ($bind_operator =~ / !~ /oxms) {
834 0         0 return not $tr;
835             }
836             else {
837 0         0 return $tr;
838             }
839             }
840             }
841              
842             #
843             # Latin-6 chop
844             #
845             sub Elatin6::chop(@) {
846              
847 0     0 0 0 my $chop;
848 0 0       0 if (@_ == 0) {
849 0         0 my @char = /\G (?>$q_char) /oxmsg;
850 0         0 $chop = pop @char;
851 0         0 $_ = join '', @char;
852             }
853             else {
854 0         0 for (@_) {
855 0         0 my @char = /\G (?>$q_char) /oxmsg;
856 0         0 $chop = pop @char;
857 0         0 $_ = join '', @char;
858             }
859             }
860 0         0 return $chop;
861             }
862              
863             #
864             # Latin-6 index by octet
865             #
866             sub Elatin6::index($$;$) {
867              
868 0     0 1 0 my($str,$substr,$position) = @_;
869 0   0     0 $position ||= 0;
870 0         0 my $pos = 0;
871              
872 0         0 while ($pos < CORE::length($str)) {
873 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
874 0 0       0 if ($pos >= $position) {
875 0         0 return $pos;
876             }
877             }
878 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
879 0         0 $pos += CORE::length($1);
880             }
881             else {
882 0         0 $pos += 1;
883             }
884             }
885 0         0 return -1;
886             }
887              
888             #
889             # Latin-6 reverse index
890             #
891             sub Elatin6::rindex($$;$) {
892              
893 0     0 0 0 my($str,$substr,$position) = @_;
894 0   0     0 $position ||= CORE::length($str) - 1;
895 0         0 my $pos = 0;
896 0         0 my $rindex = -1;
897              
898 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
899 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
900 0         0 $rindex = $pos;
901             }
902 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
903 0         0 $pos += CORE::length($1);
904             }
905             else {
906 0         0 $pos += 1;
907             }
908             }
909 0         0 return $rindex;
910             }
911              
912             #
913             # Latin-6 lower case first with parameter
914             #
915             sub Elatin6::lcfirst(@) {
916 0 0   0 0 0 if (@_) {
917 0         0 my $s = shift @_;
918 0 0 0     0 if (@_ and wantarray) {
919 0         0 return Elatin6::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
920             }
921             else {
922 0         0 return Elatin6::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
923             }
924             }
925             else {
926 0         0 return Elatin6::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
927             }
928             }
929              
930             #
931             # Latin-6 lower case first without parameter
932             #
933             sub Elatin6::lcfirst_() {
934 0     0 0 0 return Elatin6::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
935             }
936              
937             #
938             # Latin-6 lower case with parameter
939             #
940             sub Elatin6::lc(@) {
941 0 0   0 0 0 if (@_) {
942 0         0 my $s = shift @_;
943 0 0 0     0 if (@_ and wantarray) {
944 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
945             }
946             else {
947 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
948             }
949             }
950             else {
951 0         0 return Elatin6::lc_();
952             }
953             }
954              
955             #
956             # Latin-6 lower case without parameter
957             #
958             sub Elatin6::lc_() {
959 0     0 0 0 my $s = $_;
960 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
961             }
962              
963             #
964             # Latin-6 upper case first with parameter
965             #
966             sub Elatin6::ucfirst(@) {
967 0 0   0 0 0 if (@_) {
968 0         0 my $s = shift @_;
969 0 0 0     0 if (@_ and wantarray) {
970 0         0 return Elatin6::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
971             }
972             else {
973 0         0 return Elatin6::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
974             }
975             }
976             else {
977 0         0 return Elatin6::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
978             }
979             }
980              
981             #
982             # Latin-6 upper case first without parameter
983             #
984             sub Elatin6::ucfirst_() {
985 0     0 0 0 return Elatin6::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
986             }
987              
988             #
989             # Latin-6 upper case with parameter
990             #
991             sub Elatin6::uc(@) {
992 0 50   174 0 0 if (@_) {
993 174         287 my $s = shift @_;
994 174 50 33     231 if (@_ and wantarray) {
995 174 0       367 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
996             }
997             else {
998 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         671  
999             }
1000             }
1001             else {
1002 174         625 return Elatin6::uc_();
1003             }
1004             }
1005              
1006             #
1007             # Latin-6 upper case without parameter
1008             #
1009             sub Elatin6::uc_() {
1010 0     0 0 0 my $s = $_;
1011 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1012             }
1013              
1014             #
1015             # Latin-6 fold case with parameter
1016             #
1017             sub Elatin6::fc(@) {
1018 0 50   197 0 0 if (@_) {
1019 197         282 my $s = shift @_;
1020 197 50 33     285 if (@_ and wantarray) {
1021 197 0       459 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1022             }
1023             else {
1024 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         492  
1025             }
1026             }
1027             else {
1028 197         1105 return Elatin6::fc_();
1029             }
1030             }
1031              
1032             #
1033             # Latin-6 fold case without parameter
1034             #
1035             sub Elatin6::fc_() {
1036 0     0 0 0 my $s = $_;
1037 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1038             }
1039              
1040             #
1041             # Latin-6 regexp capture
1042             #
1043             {
1044             sub Elatin6::capture {
1045 0     0 1 0 return $_[0];
1046             }
1047             }
1048              
1049             #
1050             # Latin-6 regexp ignore case modifier
1051             #
1052             sub Elatin6::ignorecase {
1053              
1054 0     0 0 0 my @string = @_;
1055 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1056              
1057             # ignore case of $scalar or @array
1058 0         0 for my $string (@string) {
1059              
1060             # split regexp
1061 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1062              
1063             # unescape character
1064 0         0 for (my $i=0; $i <= $#char; $i++) {
1065 0 0       0 next if not defined $char[$i];
1066              
1067             # open character class [...]
1068 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1069 0         0 my $left = $i;
1070              
1071             # [] make die "unmatched [] in regexp ...\n"
1072              
1073 0 0       0 if ($char[$i+1] eq ']') {
1074 0         0 $i++;
1075             }
1076              
1077 0         0 while (1) {
1078 0 0       0 if (++$i > $#char) {
1079 0         0 croak "Unmatched [] in regexp";
1080             }
1081 0 0       0 if ($char[$i] eq ']') {
1082 0         0 my $right = $i;
1083 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1084              
1085             # escape character
1086 0         0 for my $char (@charlist) {
1087 0 0       0 if (0) {
1088             }
1089              
1090 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1091 0         0 $char = '\\' . $char;
1092             }
1093             }
1094              
1095             # [...]
1096 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1097              
1098 0         0 $i = $left;
1099 0         0 last;
1100             }
1101             }
1102             }
1103              
1104             # open character class [^...]
1105             elsif ($char[$i] eq '[^') {
1106 0         0 my $left = $i;
1107              
1108             # [^] make die "unmatched [] in regexp ...\n"
1109              
1110 0 0       0 if ($char[$i+1] eq ']') {
1111 0         0 $i++;
1112             }
1113              
1114 0         0 while (1) {
1115 0 0       0 if (++$i > $#char) {
1116 0         0 croak "Unmatched [] in regexp";
1117             }
1118 0 0       0 if ($char[$i] eq ']') {
1119 0         0 my $right = $i;
1120 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1121              
1122             # escape character
1123 0         0 for my $char (@charlist) {
1124 0 0       0 if (0) {
1125             }
1126              
1127 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1128 0         0 $char = '\\' . $char;
1129             }
1130             }
1131              
1132             # [^...]
1133 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1134              
1135 0         0 $i = $left;
1136 0         0 last;
1137             }
1138             }
1139             }
1140              
1141             # rewrite classic character class or escape character
1142             elsif (my $char = classic_character_class($char[$i])) {
1143 0         0 $char[$i] = $char;
1144             }
1145              
1146             # with /i modifier
1147             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1148 0         0 my $uc = Elatin6::uc($char[$i]);
1149 0         0 my $fc = Elatin6::fc($char[$i]);
1150 0 0       0 if ($uc ne $fc) {
1151 0 0       0 if (CORE::length($fc) == 1) {
1152 0         0 $char[$i] = '[' . $uc . $fc . ']';
1153             }
1154             else {
1155 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1156             }
1157             }
1158             }
1159             }
1160              
1161             # characterize
1162 0         0 for (my $i=0; $i <= $#char; $i++) {
1163 0 0       0 next if not defined $char[$i];
1164              
1165 0 0       0 if (0) {
1166             }
1167              
1168             # quote character before ? + * {
1169 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1170 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1171 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1172             }
1173             }
1174             }
1175              
1176 0         0 $string = join '', @char;
1177             }
1178              
1179             # make regexp string
1180 0         0 return @string;
1181             }
1182              
1183             #
1184             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1185             #
1186             sub Elatin6::classic_character_class {
1187 0     1867 0 0 my($char) = @_;
1188              
1189             return {
1190             '\D' => '${Elatin6::eD}',
1191             '\S' => '${Elatin6::eS}',
1192             '\W' => '${Elatin6::eW}',
1193             '\d' => '[0-9]',
1194              
1195             # Before Perl 5.6, \s only matched the five whitespace characters
1196             # tab, newline, form-feed, carriage return, and the space character
1197             # itself, which, taken together, is the character class [\t\n\f\r ].
1198              
1199             # Vertical tabs are now whitespace
1200             # \s in a regex now matches a vertical tab in all circumstances.
1201             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1202             # \t \n \v \f \r space
1203             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1204             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1205             '\s' => '\s',
1206              
1207             '\w' => '[0-9A-Z_a-z]',
1208             '\C' => '[\x00-\xFF]',
1209             '\X' => 'X',
1210              
1211             # \h \v \H \V
1212              
1213             # P.114 Character Class Shortcuts
1214             # in Chapter 7: In the World of Regular Expressions
1215             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1216              
1217             # P.357 13.2.3 Whitespace
1218             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1219             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1220             #
1221             # 0x00009 CHARACTER TABULATION h s
1222             # 0x0000a LINE FEED (LF) vs
1223             # 0x0000b LINE TABULATION v
1224             # 0x0000c FORM FEED (FF) vs
1225             # 0x0000d CARRIAGE RETURN (CR) vs
1226             # 0x00020 SPACE h s
1227              
1228             # P.196 Table 5-9. Alphanumeric regex metasymbols
1229             # in Chapter 5. Pattern Matching
1230             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1231              
1232             # (and so on)
1233              
1234             '\H' => '${Elatin6::eH}',
1235             '\V' => '${Elatin6::eV}',
1236             '\h' => '[\x09\x20]',
1237             '\v' => '[\x0A\x0B\x0C\x0D]',
1238             '\R' => '${Elatin6::eR}',
1239              
1240             # \N
1241             #
1242             # http://perldoc.perl.org/perlre.html
1243             # Character Classes and other Special Escapes
1244             # Any character but \n (experimental). Not affected by /s modifier
1245              
1246             '\N' => '${Elatin6::eN}',
1247              
1248             # \b \B
1249              
1250             # P.180 Boundaries: The \b and \B Assertions
1251             # in Chapter 5: Pattern Matching
1252             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1253              
1254             # P.219 Boundaries: The \b and \B Assertions
1255             # in Chapter 5: Pattern Matching
1256             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1257              
1258             # \b really means (?:(?<=\w)(?!\w)|(?
1259             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1260             '\b' => '${Elatin6::eb}',
1261              
1262             # \B really means (?:(?<=\w)(?=\w)|(?
1263             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1264             '\B' => '${Elatin6::eB}',
1265              
1266 1867   100     2862 }->{$char} || '';
1267             }
1268              
1269             #
1270             # prepare Latin-6 characters per length
1271             #
1272              
1273             # 1 octet characters
1274             my @chars1 = ();
1275             sub chars1 {
1276 1867 0   0 0 73540 if (@chars1) {
1277 0         0 return @chars1;
1278             }
1279 0 0       0 if (exists $range_tr{1}) {
1280 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1281 0         0 while (my @range = splice(@ranges,0,1)) {
1282 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1283 0         0 push @chars1, pack 'C', $oct0;
1284             }
1285             }
1286             }
1287 0         0 return @chars1;
1288             }
1289              
1290             # 2 octets characters
1291             my @chars2 = ();
1292             sub chars2 {
1293 0 0   0 0 0 if (@chars2) {
1294 0         0 return @chars2;
1295             }
1296 0 0       0 if (exists $range_tr{2}) {
1297 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1298 0         0 while (my @range = splice(@ranges,0,2)) {
1299 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1300 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1301 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1302             }
1303             }
1304             }
1305             }
1306 0         0 return @chars2;
1307             }
1308              
1309             # 3 octets characters
1310             my @chars3 = ();
1311             sub chars3 {
1312 0 0   0 0 0 if (@chars3) {
1313 0         0 return @chars3;
1314             }
1315 0 0       0 if (exists $range_tr{3}) {
1316 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1317 0         0 while (my @range = splice(@ranges,0,3)) {
1318 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1319 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1320 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1321 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1322             }
1323             }
1324             }
1325             }
1326             }
1327 0         0 return @chars3;
1328             }
1329              
1330             # 4 octets characters
1331             my @chars4 = ();
1332             sub chars4 {
1333 0 0   0 0 0 if (@chars4) {
1334 0         0 return @chars4;
1335             }
1336 0 0       0 if (exists $range_tr{4}) {
1337 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1338 0         0 while (my @range = splice(@ranges,0,4)) {
1339 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1340 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1341 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1342 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1343 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1344             }
1345             }
1346             }
1347             }
1348             }
1349             }
1350 0         0 return @chars4;
1351             }
1352              
1353             #
1354             # Latin-6 open character list for tr
1355             #
1356             sub _charlist_tr {
1357              
1358 0     0   0 local $_ = shift @_;
1359              
1360             # unescape character
1361 0         0 my @char = ();
1362 0         0 while (not /\G \z/oxmsgc) {
1363 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1364 0         0 push @char, '\-';
1365             }
1366             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1367 0         0 push @char, CORE::chr(oct $1);
1368             }
1369             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1370 0         0 push @char, CORE::chr(hex $1);
1371             }
1372             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1373 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1374             }
1375             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1376             push @char, {
1377             '\0' => "\0",
1378             '\n' => "\n",
1379             '\r' => "\r",
1380             '\t' => "\t",
1381             '\f' => "\f",
1382             '\b' => "\x08", # \b means backspace in character class
1383             '\a' => "\a",
1384             '\e' => "\e",
1385 0         0 }->{$1};
1386             }
1387             elsif (/\G \\ ($q_char) /oxmsgc) {
1388 0         0 push @char, $1;
1389             }
1390             elsif (/\G ($q_char) /oxmsgc) {
1391 0         0 push @char, $1;
1392             }
1393             }
1394              
1395             # join separated multiple-octet
1396 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1397              
1398             # unescape '-'
1399 0         0 my @i = ();
1400 0         0 for my $i (0 .. $#char) {
1401 0 0       0 if ($char[$i] eq '\-') {
    0          
1402 0         0 $char[$i] = '-';
1403             }
1404             elsif ($char[$i] eq '-') {
1405 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1406 0         0 push @i, $i;
1407             }
1408             }
1409             }
1410              
1411             # open character list (reverse for splice)
1412 0         0 for my $i (CORE::reverse @i) {
1413 0         0 my @range = ();
1414              
1415             # range error
1416 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1417 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1418             }
1419              
1420             # range of multiple-octet code
1421 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1422 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1423 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1424             }
1425             elsif (CORE::length($char[$i+1]) == 2) {
1426 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1427 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1428             }
1429             elsif (CORE::length($char[$i+1]) == 3) {
1430 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1431 0         0 push @range, chars2();
1432 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1433             }
1434             elsif (CORE::length($char[$i+1]) == 4) {
1435 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1436 0         0 push @range, chars2();
1437 0         0 push @range, chars3();
1438 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1439             }
1440             else {
1441 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1442             }
1443             }
1444             elsif (CORE::length($char[$i-1]) == 2) {
1445 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1446 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1447             }
1448             elsif (CORE::length($char[$i+1]) == 3) {
1449 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1450 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1451             }
1452             elsif (CORE::length($char[$i+1]) == 4) {
1453 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1454 0         0 push @range, chars3();
1455 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1456             }
1457             else {
1458 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1459             }
1460             }
1461             elsif (CORE::length($char[$i-1]) == 3) {
1462 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1463 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1464             }
1465             elsif (CORE::length($char[$i+1]) == 4) {
1466 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1467 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1468             }
1469             else {
1470 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1471             }
1472             }
1473             elsif (CORE::length($char[$i-1]) == 4) {
1474 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1475 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1476             }
1477             else {
1478 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1479             }
1480             }
1481             else {
1482 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1483             }
1484              
1485 0         0 splice @char, $i-1, 3, @range;
1486             }
1487              
1488 0         0 return @char;
1489             }
1490              
1491             #
1492             # Latin-6 open character class
1493             #
1494             sub _cc {
1495 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1496 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1497             }
1498             elsif (scalar(@_) == 1) {
1499 0         0 return sprintf('\x%02X',$_[0]);
1500             }
1501             elsif (scalar(@_) == 2) {
1502 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1503 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1504             }
1505             elsif ($_[0] == $_[1]) {
1506 0         0 return sprintf('\x%02X',$_[0]);
1507             }
1508             elsif (($_[0]+1) == $_[1]) {
1509 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1510             }
1511             else {
1512 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1513             }
1514             }
1515             else {
1516 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1517             }
1518             }
1519              
1520             #
1521             # Latin-6 octet range
1522             #
1523             sub _octets {
1524 0     182   0 my $length = shift @_;
1525              
1526 182 50       294 if ($length == 1) {
1527 182         424 my($a1) = unpack 'C', $_[0];
1528 182         477 my($z1) = unpack 'C', $_[1];
1529              
1530 182 50       333 if ($a1 > $z1) {
1531 182         346 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1532             }
1533              
1534 0 50       0 if ($a1 == $z1) {
    50          
1535 182         498 return sprintf('\x%02X',$a1);
1536             }
1537             elsif (($a1+1) == $z1) {
1538 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1539             }
1540             else {
1541 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1542             }
1543             }
1544             else {
1545 182         1404 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1546             }
1547             }
1548              
1549             #
1550             # Latin-6 range regexp
1551             #
1552             sub _range_regexp {
1553 0     182   0 my($length,$first,$last) = @_;
1554              
1555 182         381 my @range_regexp = ();
1556 182 50       255 if (not exists $range_tr{$length}) {
1557 182         516 return @range_regexp;
1558             }
1559              
1560 0         0 my @ranges = @{ $range_tr{$length} };
  182         303  
1561 182         393 while (my @range = splice(@ranges,0,$length)) {
1562 182         671 my $min = '';
1563 182         262 my $max = '';
1564 182         269 for (my $i=0; $i < $length; $i++) {
1565 182         441 $min .= pack 'C', $range[$i][0];
1566 182         687 $max .= pack 'C', $range[$i][-1];
1567             }
1568              
1569             # min___max
1570             # FIRST_____________LAST
1571             # (nothing)
1572              
1573 182 50 33     412 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1574             }
1575              
1576             # **********
1577             # min_________max
1578             # FIRST_____________LAST
1579             # **********
1580              
1581             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1582 182         2431 push @range_regexp, _octets($length,$first,$max,$min,$max);
1583             }
1584              
1585             # **********************
1586             # min________________max
1587             # FIRST_____________LAST
1588             # **********************
1589              
1590             elsif (($min eq $first) and ($max eq $last)) {
1591 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1592             }
1593              
1594             # *********
1595             # min___max
1596             # FIRST_____________LAST
1597             # *********
1598              
1599             elsif (($first le $min) and ($max le $last)) {
1600 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1601             }
1602              
1603             # **********************
1604             # min__________________________max
1605             # FIRST_____________LAST
1606             # **********************
1607              
1608             elsif (($min le $first) and ($last le $max)) {
1609 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1610             }
1611              
1612             # *********
1613             # min________max
1614             # FIRST_____________LAST
1615             # *********
1616              
1617             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1618 182         622 push @range_regexp, _octets($length,$min,$last,$min,$max);
1619             }
1620              
1621             # min___max
1622             # FIRST_____________LAST
1623             # (nothing)
1624              
1625             elsif ($last lt $min) {
1626             }
1627              
1628             else {
1629 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1630             }
1631             }
1632              
1633 0         0 return @range_regexp;
1634             }
1635              
1636             #
1637             # Latin-6 open character list for qr and not qr
1638             #
1639             sub _charlist {
1640              
1641 182     358   849 my $modifier = pop @_;
1642 358         664 my @char = @_;
1643              
1644 358 100       806 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1645              
1646             # unescape character
1647 358         956 for (my $i=0; $i <= $#char; $i++) {
1648              
1649             # escape - to ...
1650 358 100 100     1222 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1651 1125 100 100     7895 if ((0 < $i) and ($i < $#char)) {
1652 206         763 $char[$i] = '...';
1653             }
1654             }
1655              
1656             # octal escape sequence
1657             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1658 182         378 $char[$i] = octchr($1);
1659             }
1660              
1661             # hexadecimal escape sequence
1662             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1663 0         0 $char[$i] = hexchr($1);
1664             }
1665              
1666             # \b{...} --> b\{...}
1667             # \B{...} --> B\{...}
1668             # \N{CHARNAME} --> N\{CHARNAME}
1669             # \p{PROPERTY} --> p\{PROPERTY}
1670             # \P{PROPERTY} --> P\{PROPERTY}
1671             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1672 0         0 $char[$i] = $1 . '\\' . $2;
1673             }
1674              
1675             # \p, \P, \X --> p, P, X
1676             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1677 0         0 $char[$i] = $1;
1678             }
1679              
1680             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1681 0         0 $char[$i] = CORE::chr oct $1;
1682             }
1683             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1684 0         0 $char[$i] = CORE::chr hex $1;
1685             }
1686             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1687 22         112 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1688             }
1689             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1690             $char[$i] = {
1691             '\0' => "\0",
1692             '\n' => "\n",
1693             '\r' => "\r",
1694             '\t' => "\t",
1695             '\f' => "\f",
1696             '\b' => "\x08", # \b means backspace in character class
1697             '\a' => "\a",
1698             '\e' => "\e",
1699             '\d' => '[0-9]',
1700              
1701             # Vertical tabs are now whitespace
1702             # \s in a regex now matches a vertical tab in all circumstances.
1703             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1704             # \t \n \v \f \r space
1705             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1706             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1707             '\s' => '\s',
1708              
1709             '\w' => '[0-9A-Z_a-z]',
1710             '\D' => '${Elatin6::eD}',
1711             '\S' => '${Elatin6::eS}',
1712             '\W' => '${Elatin6::eW}',
1713              
1714             '\H' => '${Elatin6::eH}',
1715             '\V' => '${Elatin6::eV}',
1716             '\h' => '[\x09\x20]',
1717             '\v' => '[\x0A\x0B\x0C\x0D]',
1718             '\R' => '${Elatin6::eR}',
1719              
1720 0         0 }->{$1};
1721             }
1722              
1723             # POSIX-style character classes
1724             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1725             $char[$i] = {
1726              
1727             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1728             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1729             '[:^lower:]' => '${Elatin6::not_lower_i}',
1730             '[:^upper:]' => '${Elatin6::not_upper_i}',
1731              
1732 25         456 }->{$1};
1733             }
1734             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1735             $char[$i] = {
1736              
1737             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1738             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1739             '[:ascii:]' => '[\x00-\x7F]',
1740             '[:blank:]' => '[\x09\x20]',
1741             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1742             '[:digit:]' => '[\x30-\x39]',
1743             '[:graph:]' => '[\x21-\x7F]',
1744             '[:lower:]' => '[\x61-\x7A]',
1745             '[:print:]' => '[\x20-\x7F]',
1746             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1747              
1748             # P.174 POSIX-Style Character Classes
1749             # in Chapter 5: Pattern Matching
1750             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1751              
1752             # P.311 11.2.4 Character Classes and other Special Escapes
1753             # in Chapter 11: perlre: Perl regular expressions
1754             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1755              
1756             # P.210 POSIX-Style Character Classes
1757             # in Chapter 5: Pattern Matching
1758             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1759              
1760             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1761              
1762             '[:upper:]' => '[\x41-\x5A]',
1763             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1764             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1765             '[:^alnum:]' => '${Elatin6::not_alnum}',
1766             '[:^alpha:]' => '${Elatin6::not_alpha}',
1767             '[:^ascii:]' => '${Elatin6::not_ascii}',
1768             '[:^blank:]' => '${Elatin6::not_blank}',
1769             '[:^cntrl:]' => '${Elatin6::not_cntrl}',
1770             '[:^digit:]' => '${Elatin6::not_digit}',
1771             '[:^graph:]' => '${Elatin6::not_graph}',
1772             '[:^lower:]' => '${Elatin6::not_lower}',
1773             '[:^print:]' => '${Elatin6::not_print}',
1774             '[:^punct:]' => '${Elatin6::not_punct}',
1775             '[:^space:]' => '${Elatin6::not_space}',
1776             '[:^upper:]' => '${Elatin6::not_upper}',
1777             '[:^word:]' => '${Elatin6::not_word}',
1778             '[:^xdigit:]' => '${Elatin6::not_xdigit}',
1779              
1780 8         59 }->{$1};
1781             }
1782             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1783 70         1445 $char[$i] = $1;
1784             }
1785             }
1786              
1787             # open character list
1788 7         33 my @singleoctet = ();
1789 358         704 my @multipleoctet = ();
1790 358         501 for (my $i=0; $i <= $#char; ) {
1791              
1792             # escaped -
1793 358 100 100     805 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1794 943         3964 $i += 1;
1795 182         235 next;
1796             }
1797              
1798             # make range regexp
1799             elsif ($char[$i] eq '...') {
1800              
1801             # range error
1802 182 50       316 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1803 182         666 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1804             }
1805             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1806 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1807 182         593 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1808             }
1809             }
1810              
1811             # make range regexp per length
1812 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1813 182         1612 my @regexp = ();
1814              
1815             # is first and last
1816 182 50 33     269 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1817 182         606 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1818             }
1819              
1820             # is first
1821             elsif ($length == CORE::length($char[$i-1])) {
1822 182         512 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1823             }
1824              
1825             # is inside in first and last
1826             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1827 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1828             }
1829              
1830             # is last
1831             elsif ($length == CORE::length($char[$i+1])) {
1832 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1833             }
1834              
1835             else {
1836 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1837             }
1838              
1839 0 50       0 if ($length == 1) {
1840 182         371 push @singleoctet, @regexp;
1841             }
1842             else {
1843 182         411 push @multipleoctet, @regexp;
1844             }
1845             }
1846              
1847 0         0 $i += 2;
1848             }
1849              
1850             # with /i modifier
1851             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1852 182 100       366 if ($modifier =~ /i/oxms) {
1853 493         734 my $uc = Elatin6::uc($char[$i]);
1854 24         52 my $fc = Elatin6::fc($char[$i]);
1855 24 100       49 if ($uc ne $fc) {
1856 24 50       44 if (CORE::length($fc) == 1) {
1857 12         24 push @singleoctet, $uc, $fc;
1858             }
1859             else {
1860 12         20 push @singleoctet, $uc;
1861 0         0 push @multipleoctet, $fc;
1862             }
1863             }
1864             else {
1865 0         0 push @singleoctet, $char[$i];
1866             }
1867             }
1868             else {
1869 12         25 push @singleoctet, $char[$i];
1870             }
1871 469         651 $i += 1;
1872             }
1873              
1874             # single character of single octet code
1875             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1876 493         775 push @singleoctet, "\t", "\x20";
1877 0         0 $i += 1;
1878             }
1879             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1880 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1881 0         0 $i += 1;
1882             }
1883             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1884 0         0 push @singleoctet, $char[$i];
1885 2         6 $i += 1;
1886             }
1887              
1888             # single character of multiple-octet code
1889             else {
1890 2         6 push @multipleoctet, $char[$i];
1891 84         158 $i += 1;
1892             }
1893             }
1894              
1895             # quote metachar
1896 84         181 for (@singleoctet) {
1897 358 50       653 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1898 689         2903 $_ = '-';
1899             }
1900             elsif (/\A \n \z/oxms) {
1901 0         0 $_ = '\n';
1902             }
1903             elsif (/\A \r \z/oxms) {
1904 8         18 $_ = '\r';
1905             }
1906             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1907 8         22 $_ = sprintf('\x%02X', CORE::ord $1);
1908             }
1909             elsif (/\A [\x00-\xFF] \z/oxms) {
1910 60         200 $_ = quotemeta $_;
1911             }
1912             }
1913              
1914             # return character list
1915 429         625 return \@singleoctet, \@multipleoctet;
1916             }
1917              
1918             #
1919             # Latin-6 octal escape sequence
1920             #
1921             sub octchr {
1922 358     5 0 1172 my($octdigit) = @_;
1923              
1924 5         14 my @binary = ();
1925 5         8 for my $octal (split(//,$octdigit)) {
1926             push @binary, {
1927             '0' => '000',
1928             '1' => '001',
1929             '2' => '010',
1930             '3' => '011',
1931             '4' => '100',
1932             '5' => '101',
1933             '6' => '110',
1934             '7' => '111',
1935 5         27 }->{$octal};
1936             }
1937 50         173 my $binary = join '', @binary;
1938              
1939             my $octchr = {
1940             # 1234567
1941             1 => pack('B*', "0000000$binary"),
1942             2 => pack('B*', "000000$binary"),
1943             3 => pack('B*', "00000$binary"),
1944             4 => pack('B*', "0000$binary"),
1945             5 => pack('B*', "000$binary"),
1946             6 => pack('B*', "00$binary"),
1947             7 => pack('B*', "0$binary"),
1948             0 => pack('B*', "$binary"),
1949              
1950 5         14 }->{CORE::length($binary) % 8};
1951              
1952 5         56 return $octchr;
1953             }
1954              
1955             #
1956             # Latin-6 hexadecimal escape sequence
1957             #
1958             sub hexchr {
1959 5     5 0 20 my($hexdigit) = @_;
1960              
1961             my $hexchr = {
1962             1 => pack('H*', "0$hexdigit"),
1963             0 => pack('H*', "$hexdigit"),
1964              
1965 5         14 }->{CORE::length($_[0]) % 2};
1966              
1967 5         38 return $hexchr;
1968             }
1969              
1970             #
1971             # Latin-6 open character list for qr
1972             #
1973             sub charlist_qr {
1974              
1975 5     314 0 18 my $modifier = pop @_;
1976 314         581 my @char = @_;
1977              
1978 314         738 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1979 314         965 my @singleoctet = @$singleoctet;
1980 314         659 my @multipleoctet = @$multipleoctet;
1981              
1982             # return character list
1983 314 100       478 if (scalar(@singleoctet) >= 1) {
1984              
1985             # with /i modifier
1986 314 100       770 if ($modifier =~ m/i/oxms) {
1987 236         514 my %singleoctet_ignorecase = ();
1988 22         32 for (@singleoctet) {
1989 22   100     38 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1990 46         198 for my $ord (hex($1) .. hex($2)) {
1991 46         135 my $char = CORE::chr($ord);
1992 66         113 my $uc = Elatin6::uc($char);
1993 66         89 my $fc = Elatin6::fc($char);
1994 66 100       105 if ($uc eq $fc) {
1995 66         115 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1996             }
1997             else {
1998 12 50       80 if (CORE::length($fc) == 1) {
1999 54         75 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2000 54         126 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2001             }
2002             else {
2003 54         227 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2004 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2005             }
2006             }
2007             }
2008             }
2009 0 50       0 if ($_ ne '') {
2010 46         155 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2011             }
2012             }
2013 0         0 my $i = 0;
2014 22         65 my @singleoctet_ignorecase = ();
2015 22         30 for my $ord (0 .. 255) {
2016 22 100       40 if (exists $singleoctet_ignorecase{$ord}) {
2017 5632         7665 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         102  
2018             }
2019             else {
2020 96         1782 $i++;
2021             }
2022             }
2023 5536         8775 @singleoctet = ();
2024 22         39 for my $range (@singleoctet_ignorecase) {
2025 22 100       64 if (ref $range) {
2026 3648 100       6587 if (scalar(@{$range}) == 1) {
  56 50       56  
2027 56         93 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         40  
2028             }
2029 36         114 elsif (scalar(@{$range}) == 2) {
2030 20         27 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2031             }
2032             else {
2033 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         26  
  20         23  
2034             }
2035             }
2036             }
2037             }
2038              
2039 20         99 my $not_anchor = '';
2040              
2041 236         368 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2042             }
2043 236 100       613 if (scalar(@multipleoctet) >= 2) {
2044 314         612 return '(?:' . join('|', @multipleoctet) . ')';
2045             }
2046             else {
2047 6         33 return $multipleoctet[0];
2048             }
2049             }
2050              
2051             #
2052             # Latin-6 open character list for not qr
2053             #
2054             sub charlist_not_qr {
2055              
2056 308     44 0 1441 my $modifier = pop @_;
2057 44         90 my @char = @_;
2058              
2059 44         102 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2060 44         154 my @singleoctet = @$singleoctet;
2061 44         118 my @multipleoctet = @$multipleoctet;
2062              
2063             # with /i modifier
2064 44 100       118 if ($modifier =~ m/i/oxms) {
2065 44         106 my %singleoctet_ignorecase = ();
2066 10         12 for (@singleoctet) {
2067 10   66     17 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2068 10         46 for my $ord (hex($1) .. hex($2)) {
2069 10         37 my $char = CORE::chr($ord);
2070 30         49 my $uc = Elatin6::uc($char);
2071 30         49 my $fc = Elatin6::fc($char);
2072 30 50       50 if ($uc eq $fc) {
2073 30         98 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2074             }
2075             else {
2076 0 50       0 if (CORE::length($fc) == 1) {
2077 30         41 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2078 30         65 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2079             }
2080             else {
2081 30         103 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2082 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2083             }
2084             }
2085             }
2086             }
2087 0 50       0 if ($_ ne '') {
2088 10         32 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2089             }
2090             }
2091 0         0 my $i = 0;
2092 10         11 my @singleoctet_ignorecase = ();
2093 10         15 for my $ord (0 .. 255) {
2094 10 100       24 if (exists $singleoctet_ignorecase{$ord}) {
2095 2560         2947 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         56  
2096             }
2097             else {
2098 60         101 $i++;
2099             }
2100             }
2101 2500         2604 @singleoctet = ();
2102 10         16 for my $range (@singleoctet_ignorecase) {
2103 10 100       25 if (ref $range) {
2104 960 50       1505 if (scalar(@{$range}) == 1) {
  20 50       20  
2105 20         34 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2106             }
2107 0         0 elsif (scalar(@{$range}) == 2) {
2108 20         27 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2109             }
2110             else {
2111 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         25  
  20         25  
2112             }
2113             }
2114             }
2115             }
2116              
2117             # return character list
2118 20 50       85 if (scalar(@multipleoctet) >= 1) {
2119 44 0       196 if (scalar(@singleoctet) >= 1) {
2120              
2121             # any character other than multiple-octet and single octet character class
2122 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2123             }
2124             else {
2125              
2126             # any character other than multiple-octet character class
2127 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2128             }
2129             }
2130             else {
2131 0 50       0 if (scalar(@singleoctet) >= 1) {
2132              
2133             # any character other than single octet character class
2134 44         124 return '(?:[^' . join('', @singleoctet) . '])';
2135             }
2136             else {
2137              
2138             # any character
2139 44         257 return "(?:$your_char)";
2140             }
2141             }
2142             }
2143              
2144             #
2145             # open file in read mode
2146             #
2147             sub _open_r {
2148 0     408   0 my(undef,$file) = @_;
2149 204     204   2569 use Fcntl qw(O_RDONLY);
  204         537  
  204         32597  
2150 408         1151 return CORE::sysopen($_[0], $file, &O_RDONLY);
2151             }
2152              
2153             #
2154             # open file in append mode
2155             #
2156             sub _open_a {
2157 408     204   17064 my(undef,$file) = @_;
2158 204     204   1414 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         588  
  204         704962  
2159 204         647 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2160             }
2161              
2162             #
2163             # safe system
2164             #
2165             sub _systemx {
2166              
2167             # P.707 29.2.33. exec
2168             # in Chapter 29: Functions
2169             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2170             #
2171             # Be aware that in older releases of Perl, exec (and system) did not flush
2172             # your output buffer, so you needed to enable command buffering by setting $|
2173             # on one or more filehandles to avoid lost output in the case of exec, or
2174             # misordererd output in the case of system. This situation was largely remedied
2175             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2176              
2177             # P.855 exec
2178             # in Chapter 27: Functions
2179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2180             #
2181             # In very old release of Perl (before v5.6), exec (and system) did not flush
2182             # your output buffer, so you needed to enable command buffering by setting $|
2183             # on one or more filehandles to avoid lost output with exec or misordered
2184             # output with system.
2185              
2186 204     204   23969 $| = 1;
2187              
2188             # P.565 23.1.2. Cleaning Up Your Environment
2189             # in Chapter 23: Security
2190             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2191              
2192             # P.656 Cleaning Up Your Environment
2193             # in Chapter 20: Security
2194             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2195              
2196             # local $ENV{'PATH'} = '.';
2197 204         795 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2198              
2199             # P.707 29.2.33. exec
2200             # in Chapter 29: Functions
2201             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2202             #
2203             # As we mentioned earlier, exec treats a discrete list of arguments as an
2204             # indication that it should bypass shell processing. However, there is one
2205             # place where you might still get tripped up. The exec call (and system, too)
2206             # will not distinguish between a single scalar argument and an array containing
2207             # only one element.
2208             #
2209             # @args = ("echo surprise"); # just one element in list
2210             # exec @args # still subject to shell escapes
2211             # or die "exec: $!"; # because @args == 1
2212             #
2213             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2214             # first argument as the pathname, which forces the rest of the arguments to be
2215             # interpreted as a list, even if there is only one of them:
2216             #
2217             # exec { $args[0] } @args # safe even with one-argument list
2218             # or die "can't exec @args: $!";
2219              
2220             # P.855 exec
2221             # in Chapter 27: Functions
2222             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2223             #
2224             # As we mentioned earlier, exec treats a discrete list of arguments as a
2225             # directive to bypass shell processing. However, there is one place where
2226             # you might still get tripped up. The exec call (and system, too) cannot
2227             # distinguish between a single scalar argument and an array containing
2228             # only one element.
2229             #
2230             # @args = ("echo surprise"); # just one element in list
2231             # exec @args # still subject to shell escapes
2232             # || die "exec: $!"; # because @args == 1
2233             #
2234             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2235             # argument as the pathname, which forces the rest of the arguments to be
2236             # interpreted as a list, even if there is only one of them:
2237             #
2238             # exec { $args[0] } @args # safe even with one-argument list
2239             # || die "can't exec @args: $!";
2240              
2241 204         1992 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         520  
2242             }
2243              
2244             #
2245             # Latin-6 order to character (with parameter)
2246             #
2247             sub Elatin6::chr(;$) {
2248              
2249 204 0   0 0 20725005 my $c = @_ ? $_[0] : $_;
2250              
2251 0 0       0 if ($c == 0x00) {
2252 0         0 return "\x00";
2253             }
2254             else {
2255 0         0 my @chr = ();
2256 0         0 while ($c > 0) {
2257 0         0 unshift @chr, ($c % 0x100);
2258 0         0 $c = int($c / 0x100);
2259             }
2260 0         0 return pack 'C*', @chr;
2261             }
2262             }
2263              
2264             #
2265             # Latin-6 order to character (without parameter)
2266             #
2267             sub Elatin6::chr_() {
2268              
2269 0     0 0 0 my $c = $_;
2270              
2271 0 0       0 if ($c == 0x00) {
2272 0         0 return "\x00";
2273             }
2274             else {
2275 0         0 my @chr = ();
2276 0         0 while ($c > 0) {
2277 0         0 unshift @chr, ($c % 0x100);
2278 0         0 $c = int($c / 0x100);
2279             }
2280 0         0 return pack 'C*', @chr;
2281             }
2282             }
2283              
2284             #
2285             # Latin-6 path globbing (with parameter)
2286             #
2287             sub Elatin6::glob($) {
2288              
2289 0 0   0 0 0 if (wantarray) {
2290 0         0 my @glob = _DOS_like_glob(@_);
2291 0         0 for my $glob (@glob) {
2292 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2293             }
2294 0         0 return @glob;
2295             }
2296             else {
2297 0         0 my $glob = _DOS_like_glob(@_);
2298 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2299 0         0 return $glob;
2300             }
2301             }
2302              
2303             #
2304             # Latin-6 path globbing (without parameter)
2305             #
2306             sub Elatin6::glob_() {
2307              
2308 0 0   0 0 0 if (wantarray) {
2309 0         0 my @glob = _DOS_like_glob();
2310 0         0 for my $glob (@glob) {
2311 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2312             }
2313 0         0 return @glob;
2314             }
2315             else {
2316 0         0 my $glob = _DOS_like_glob();
2317 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2318 0         0 return $glob;
2319             }
2320             }
2321              
2322             #
2323             # Latin-6 path globbing via File::DosGlob 1.10
2324             #
2325             # Often I confuse "_dosglob" and "_doglob".
2326             # So, I renamed "_dosglob" to "_DOS_like_glob".
2327             #
2328             my %iter;
2329             my %entries;
2330             sub _DOS_like_glob {
2331              
2332             # context (keyed by second cxix argument provided by core)
2333 0     0   0 my($expr,$cxix) = @_;
2334              
2335             # glob without args defaults to $_
2336 0 0       0 $expr = $_ if not defined $expr;
2337              
2338             # represents the current user's home directory
2339             #
2340             # 7.3. Expanding Tildes in Filenames
2341             # in Chapter 7. File Access
2342             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2343             #
2344             # and File::HomeDir, File::HomeDir::Windows module
2345              
2346             # DOS-like system
2347 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2348 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2349             { my_home_MSWin32() }oxmse;
2350             }
2351              
2352             # UNIX-like system
2353 0 0 0     0 else {
  0         0  
2354             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2355             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2356             }
2357 0 0       0  
2358 0 0       0 # assume global context if not provided one
2359             $cxix = '_G_' if not defined $cxix;
2360             $iter{$cxix} = 0 if not exists $iter{$cxix};
2361 0 0       0  
2362 0         0 # if we're just beginning, do it all first
2363             if ($iter{$cxix} == 0) {
2364             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2365             }
2366 0 0       0  
2367 0         0 # chuck it all out, quick or slow
2368 0         0 if (wantarray) {
  0         0  
2369             delete $iter{$cxix};
2370             return @{delete $entries{$cxix}};
2371 0 0       0 }
  0         0  
2372 0         0 else {
  0         0  
2373             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2374             return shift @{$entries{$cxix}};
2375             }
2376 0         0 else {
2377 0         0 # return undef for EOL
2378 0         0 delete $iter{$cxix};
2379             delete $entries{$cxix};
2380             return undef;
2381             }
2382             }
2383             }
2384              
2385             #
2386             # Latin-6 path globbing subroutine
2387             #
2388 0     0   0 sub _do_glob {
2389 0         0  
2390 0         0 my($cond,@expr) = @_;
2391             my @glob = ();
2392             my $fix_drive_relative_paths = 0;
2393 0         0  
2394 0 0       0 OUTER:
2395 0 0       0 for my $expr (@expr) {
2396             next OUTER if not defined $expr;
2397 0         0 next OUTER if $expr eq '';
2398 0         0  
2399 0         0 my @matched = ();
2400 0         0 my @globdir = ();
2401 0         0 my $head = '.';
2402             my $pathsep = '/';
2403             my $tail;
2404 0 0       0  
2405 0         0 # if argument is within quotes strip em and do no globbing
2406 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2407 0 0       0 $expr = $1;
2408 0         0 if ($cond eq 'd') {
2409             if (-d $expr) {
2410             push @glob, $expr;
2411             }
2412 0 0       0 }
2413 0         0 else {
2414             if (-e $expr) {
2415             push @glob, $expr;
2416 0         0 }
2417             }
2418             next OUTER;
2419             }
2420              
2421 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2422 0 0       0 # to h:./*.pm to expand correctly
2423 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2424             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2425             $fix_drive_relative_paths = 1;
2426             }
2427 0 0       0 }
2428 0 0       0  
2429 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2430 0         0 if ($tail eq '') {
2431             push @glob, $expr;
2432 0 0       0 next OUTER;
2433 0 0       0 }
2434 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2435 0         0 if (@globdir = _do_glob('d', $head)) {
2436             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2437             next OUTER;
2438 0 0 0     0 }
2439 0         0 }
2440             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2441 0         0 $head .= $pathsep;
2442             }
2443             $expr = $tail;
2444             }
2445 0 0       0  
2446 0 0       0 # If file component has no wildcards, we can avoid opendir
2447 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2448             if ($head eq '.') {
2449 0 0 0     0 $head = '';
2450 0         0 }
2451             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2452 0         0 $head .= $pathsep;
2453 0 0       0 }
2454 0 0       0 $head .= $expr;
2455 0         0 if ($cond eq 'd') {
2456             if (-d $head) {
2457             push @glob, $head;
2458             }
2459 0 0       0 }
2460 0         0 else {
2461             if (-e $head) {
2462             push @glob, $head;
2463 0         0 }
2464             }
2465 0 0       0 next OUTER;
2466 0         0 }
2467 0         0 opendir(*DIR, $head) or next OUTER;
2468             my @leaf = readdir DIR;
2469 0 0       0 closedir DIR;
2470 0         0  
2471             if ($head eq '.') {
2472 0 0 0     0 $head = '';
2473 0         0 }
2474             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2475             $head .= $pathsep;
2476 0         0 }
2477 0         0  
2478 0         0 my $pattern = '';
2479             while ($expr =~ / \G ($q_char) /oxgc) {
2480             my $char = $1;
2481              
2482             # 6.9. Matching Shell Globs as Regular Expressions
2483             # in Chapter 6. Pattern Matching
2484             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2485 0 0       0 # (and so on)
    0          
    0          
2486 0         0  
2487             if ($char eq '*') {
2488             $pattern .= "(?:$your_char)*",
2489 0         0 }
2490             elsif ($char eq '?') {
2491             $pattern .= "(?:$your_char)?", # DOS style
2492             # $pattern .= "(?:$your_char)", # UNIX style
2493 0         0 }
2494             elsif ((my $fc = Elatin6::fc($char)) ne $char) {
2495             $pattern .= $fc;
2496 0         0 }
2497             else {
2498             $pattern .= quotemeta $char;
2499 0     0   0 }
  0         0  
2500             }
2501             my $matchsub = sub { Elatin6::fc($_[0]) =~ /\A $pattern \z/xms };
2502              
2503             # if ($@) {
2504             # print STDERR "$0: $@\n";
2505             # next OUTER;
2506             # }
2507 0         0  
2508 0 0 0     0 INNER:
2509 0         0 for my $leaf (@leaf) {
2510             if ($leaf eq '.' or $leaf eq '..') {
2511 0 0 0     0 next INNER;
2512 0         0 }
2513             if ($cond eq 'd' and not -d "$head$leaf") {
2514             next INNER;
2515 0 0       0 }
2516 0         0  
2517 0         0 if (&$matchsub($leaf)) {
2518             push @matched, "$head$leaf";
2519             next INNER;
2520             }
2521              
2522             # [DOS compatibility special case]
2523 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2524              
2525             if (Elatin6::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2526             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2527 0 0       0 Elatin6::index($pattern,'\\.') != -1 # pattern has a dot.
2528 0         0 ) {
2529 0         0 if (&$matchsub("$leaf.")) {
2530             push @matched, "$head$leaf";
2531             next INNER;
2532             }
2533 0 0       0 }
2534 0         0 }
2535             if (@matched) {
2536             push @glob, @matched;
2537 0 0       0 }
2538 0         0 }
2539 0         0 if ($fix_drive_relative_paths) {
2540             for my $glob (@glob) {
2541             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2542 0         0 }
2543             }
2544             return @glob;
2545             }
2546              
2547             #
2548             # Latin-6 parse line
2549             #
2550 0     0   0 sub _parse_line {
2551              
2552 0         0 my($line) = @_;
2553 0         0  
2554 0         0 $line .= ' ';
2555             my @piece = ();
2556             while ($line =~ /
2557             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2558             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2559 0 0       0 /oxmsg
2560             ) {
2561 0         0 push @piece, defined($1) ? $1 : $2;
2562             }
2563             return @piece;
2564             }
2565              
2566             #
2567             # Latin-6 parse path
2568             #
2569 0     0   0 sub _parse_path {
2570              
2571 0         0 my($path,$pathsep) = @_;
2572 0         0  
2573 0         0 $path .= '/';
2574             my @subpath = ();
2575             while ($path =~ /
2576             ((?: [^\/\\] )+?) [\/\\]
2577 0         0 /oxmsg
2578             ) {
2579             push @subpath, $1;
2580 0         0 }
2581 0         0  
2582 0         0 my $tail = pop @subpath;
2583             my $head = join $pathsep, @subpath;
2584             return $head, $tail;
2585             }
2586              
2587             #
2588             # via File::HomeDir::Windows 1.00
2589             #
2590             sub my_home_MSWin32 {
2591              
2592             # A lot of unix people and unix-derived tools rely on
2593 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2594 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2595             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2596             return $ENV{'HOME'};
2597             }
2598              
2599 0         0 # Do we have a user profile?
2600             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2601             return $ENV{'USERPROFILE'};
2602             }
2603              
2604 0         0 # Some Windows use something like $ENV{'HOME'}
2605             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2606             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2607 0         0 }
2608              
2609             return undef;
2610             }
2611              
2612             #
2613             # via File::HomeDir::Unix 1.00
2614 0     0 0 0 #
2615             sub my_home {
2616 0 0 0     0 my $home;
    0 0        
2617 0         0  
2618             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2619             $home = $ENV{'HOME'};
2620             }
2621              
2622             # This is from the original code, but I'm guessing
2623 0         0 # it means "login directory" and exists on some Unixes.
2624             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2625             $home = $ENV{'LOGDIR'};
2626             }
2627              
2628             ### More-desperate methods
2629              
2630 0         0 # Light desperation on any (Unixish) platform
2631             else {
2632             $home = CORE::eval q{ (getpwuid($<))[7] };
2633             }
2634              
2635 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2636 0         0 # For example, "nobody"-like users might use /nonexistant
2637             if (defined $home and ! -d($home)) {
2638 0         0 $home = undef;
2639             }
2640             return $home;
2641             }
2642              
2643             #
2644             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2645 0     0 0 0 #
2646             sub Elatin6::PREMATCH {
2647             return $`;
2648             }
2649              
2650             #
2651             # ${^MATCH}, $MATCH, $& the string that matched
2652 0     0 0 0 #
2653             sub Elatin6::MATCH {
2654             return $&;
2655             }
2656              
2657             #
2658             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2659 0     0 0 0 #
2660             sub Elatin6::POSTMATCH {
2661             return $';
2662             }
2663              
2664             #
2665             # Latin-6 character to order (with parameter)
2666             #
2667 0 0   0 1 0 sub Latin6::ord(;$) {
2668              
2669 0 0       0 local $_ = shift if @_;
2670 0         0  
2671 0         0 if (/\A ($q_char) /oxms) {
2672 0         0 my @ord = unpack 'C*', $1;
2673 0         0 my $ord = 0;
2674             while (my $o = shift @ord) {
2675 0         0 $ord = $ord * 0x100 + $o;
2676             }
2677             return $ord;
2678 0         0 }
2679             else {
2680             return CORE::ord $_;
2681             }
2682             }
2683              
2684             #
2685             # Latin-6 character to order (without parameter)
2686             #
2687 0 0   0 0 0 sub Latin6::ord_() {
2688 0         0  
2689 0         0 if (/\A ($q_char) /oxms) {
2690 0         0 my @ord = unpack 'C*', $1;
2691 0         0 my $ord = 0;
2692             while (my $o = shift @ord) {
2693 0         0 $ord = $ord * 0x100 + $o;
2694             }
2695             return $ord;
2696 0         0 }
2697             else {
2698             return CORE::ord $_;
2699             }
2700             }
2701              
2702             #
2703             # Latin-6 reverse
2704             #
2705 0 0   0 0 0 sub Latin6::reverse(@) {
2706 0         0  
2707             if (wantarray) {
2708             return CORE::reverse @_;
2709             }
2710             else {
2711              
2712             # One of us once cornered Larry in an elevator and asked him what
2713             # problem he was solving with this, but he looked as far off into
2714             # the distance as he could in an elevator and said, "It seemed like
2715 0         0 # a good idea at the time."
2716              
2717             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2718             }
2719             }
2720              
2721             #
2722             # Latin-6 getc (with parameter, without parameter)
2723             #
2724 0     0 0 0 sub Latin6::getc(;*@) {
2725 0 0       0  
2726 0 0 0     0 my($package) = caller;
2727             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2728 0         0 croak 'Too many arguments for Latin6::getc' if @_ and not wantarray;
  0         0  
2729 0         0  
2730 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2731 0         0 my $getc = '';
2732 0 0       0 for my $length ($length[0] .. $length[-1]) {
2733 0 0       0 $getc .= CORE::getc($fh);
2734 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2735             if ($getc =~ /\A ${Elatin6::dot_s} \z/oxms) {
2736             return wantarray ? ($getc,@_) : $getc;
2737             }
2738 0 0       0 }
2739             }
2740             return wantarray ? ($getc,@_) : $getc;
2741             }
2742              
2743             #
2744             # Latin-6 length by character
2745             #
2746 0 0   0 1 0 sub Latin6::length(;$) {
2747              
2748 0         0 local $_ = shift if @_;
2749 0         0  
2750             local @_ = /\G ($q_char) /oxmsg;
2751             return scalar @_;
2752             }
2753              
2754             #
2755             # Latin-6 substr by character
2756             #
2757             BEGIN {
2758              
2759             # P.232 The lvalue Attribute
2760             # in Chapter 6: Subroutines
2761             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2762              
2763             # P.336 The lvalue Attribute
2764             # in Chapter 7: Subroutines
2765             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2766              
2767             # P.144 8.4 Lvalue subroutines
2768             # in Chapter 8: perlsub: Perl subroutines
2769 204 50 0 204 1 140813 # 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  
2770              
2771             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2772             # vv----------------------*******
2773             sub Latin6::substr($$;$$) %s {
2774              
2775             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2776              
2777             # If the substring is beyond either end of the string, substr() returns the undefined
2778             # value and produces a warning. When used as an lvalue, specifying a substring that
2779             # is entirely outside the string raises an exception.
2780             # http://perldoc.perl.org/functions/substr.html
2781              
2782             # A return with no argument returns the scalar value undef in scalar context,
2783             # an empty list () in list context, and (naturally) nothing at all in void
2784             # context.
2785              
2786             my $offset = $_[1];
2787             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2788             return;
2789             }
2790              
2791             # substr($string,$offset,$length,$replacement)
2792             if (@_ == 4) {
2793             my(undef,undef,$length,$replacement) = @_;
2794             my $substr = join '', splice(@char, $offset, $length, $replacement);
2795             $_[0] = join '', @char;
2796              
2797             # return $substr; this doesn't work, don't say "return"
2798             $substr;
2799             }
2800              
2801             # substr($string,$offset,$length)
2802             elsif (@_ == 3) {
2803             my(undef,undef,$length) = @_;
2804             my $octet_offset = 0;
2805             my $octet_length = 0;
2806             if ($offset == 0) {
2807             $octet_offset = 0;
2808             }
2809             elsif ($offset > 0) {
2810             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2811             }
2812             else {
2813             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2814             }
2815             if ($length == 0) {
2816             $octet_length = 0;
2817             }
2818             elsif ($length > 0) {
2819             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2820             }
2821             else {
2822             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2823             }
2824             CORE::substr($_[0], $octet_offset, $octet_length);
2825             }
2826              
2827             # substr($string,$offset)
2828             else {
2829             my $octet_offset = 0;
2830             if ($offset == 0) {
2831             $octet_offset = 0;
2832             }
2833             elsif ($offset > 0) {
2834             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2835             }
2836             else {
2837             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2838             }
2839             CORE::substr($_[0], $octet_offset);
2840             }
2841             }
2842             END
2843             }
2844              
2845             #
2846             # Latin-6 index by character
2847             #
2848 0     0 1 0 sub Latin6::index($$;$) {
2849 0 0       0  
2850 0         0 my $index;
2851             if (@_ == 3) {
2852             $index = Elatin6::index($_[0], $_[1], CORE::length(Latin6::substr($_[0], 0, $_[2])));
2853 0         0 }
2854             else {
2855             $index = Elatin6::index($_[0], $_[1]);
2856 0 0       0 }
2857 0         0  
2858             if ($index == -1) {
2859             return -1;
2860 0         0 }
2861             else {
2862             return Latin6::length(CORE::substr $_[0], 0, $index);
2863             }
2864             }
2865              
2866             #
2867             # Latin-6 rindex by character
2868             #
2869 0     0 1 0 sub Latin6::rindex($$;$) {
2870 0 0       0  
2871 0         0 my $rindex;
2872             if (@_ == 3) {
2873             $rindex = Elatin6::rindex($_[0], $_[1], CORE::length(Latin6::substr($_[0], 0, $_[2])));
2874 0         0 }
2875             else {
2876             $rindex = Elatin6::rindex($_[0], $_[1]);
2877 0 0       0 }
2878 0         0  
2879             if ($rindex == -1) {
2880             return -1;
2881 0         0 }
2882             else {
2883             return Latin6::length(CORE::substr $_[0], 0, $rindex);
2884             }
2885             }
2886              
2887 204     204   1937 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         515  
  204         23413  
2888             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2889             use vars qw($slash); $slash = 'm//';
2890              
2891             # ord() to ord() or Latin6::ord()
2892             my $function_ord = 'ord';
2893              
2894             # ord to ord or Latin6::ord_
2895             my $function_ord_ = 'ord';
2896              
2897             # reverse to reverse or Latin6::reverse
2898             my $function_reverse = 'reverse';
2899              
2900             # getc to getc or Latin6::getc
2901             my $function_getc = 'getc';
2902              
2903             # P.1023 Appendix W.9 Multibyte Anchoring
2904             # of ISBN 1-56592-224-7 CJKV Information Processing
2905              
2906 204     204   1515 my $anchor = '';
  204     0   413  
  204         10094993  
2907              
2908             use vars qw($nest);
2909              
2910             # regexp of nested parens in qqXX
2911              
2912             # P.340 Matching Nested Constructs with Embedded Code
2913             # in Chapter 7: Perl
2914             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2915              
2916             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2917             [^\\()] |
2918             \( (?{$nest++}) |
2919             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2920             \\ [^c] |
2921             \\c[\x40-\x5F] |
2922             [\x00-\xFF]
2923             }xms;
2924              
2925             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2926             [^\\{}] |
2927             \{ (?{$nest++}) |
2928             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2929             \\ [^c] |
2930             \\c[\x40-\x5F] |
2931             [\x00-\xFF]
2932             }xms;
2933              
2934             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2935             [^\\\[\]] |
2936             \[ (?{$nest++}) |
2937             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2938             \\ [^c] |
2939             \\c[\x40-\x5F] |
2940             [\x00-\xFF]
2941             }xms;
2942              
2943             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2944             [^\\<>] |
2945             \< (?{$nest++}) |
2946             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2947             \\ [^c] |
2948             \\c[\x40-\x5F] |
2949             [\x00-\xFF]
2950             }xms;
2951              
2952             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2953             (?: ::)? (?:
2954             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2955             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2956             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2957             ))
2958             }xms;
2959              
2960             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2961             (?: ::)? (?:
2962             (?>[0-9]+) |
2963             [^a-zA-Z_0-9\[\]] |
2964             ^[A-Z] |
2965             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2966             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2967             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2968             ))
2969             }xms;
2970              
2971             my $qq_substr = qr{(?> Char::substr | Latin6::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2972             }xms;
2973              
2974             # regexp of nested parens in qXX
2975             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2976             [^()] |
2977             \( (?{$nest++}) |
2978             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2979             [\x00-\xFF]
2980             }xms;
2981              
2982             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2983             [^\{\}] |
2984             \{ (?{$nest++}) |
2985             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2986             [\x00-\xFF]
2987             }xms;
2988              
2989             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2990             [^\[\]] |
2991             \[ (?{$nest++}) |
2992             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2993             [\x00-\xFF]
2994             }xms;
2995              
2996             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2997             [^<>] |
2998             \< (?{$nest++}) |
2999             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3000             [\x00-\xFF]
3001             }xms;
3002              
3003             my $matched = '';
3004             my $s_matched = '';
3005              
3006             my $tr_variable = ''; # variable of tr///
3007             my $sub_variable = ''; # variable of s///
3008             my $bind_operator = ''; # =~ or !~
3009              
3010             my @heredoc = (); # here document
3011             my @heredoc_delimiter = ();
3012             my $here_script = ''; # here script
3013              
3014             #
3015             # escape Latin-6 script
3016 0 50   204 0 0 #
3017             sub Latin6::escape(;$) {
3018             local($_) = $_[0] if @_;
3019              
3020             # P.359 The Study Function
3021             # in Chapter 7: Perl
3022 204         764 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3023              
3024             study $_; # Yes, I studied study yesterday.
3025              
3026             # while all script
3027              
3028             # 6.14. Matching from Where the Last Pattern Left Off
3029             # in Chapter 6. Pattern Matching
3030             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3031             # (and so on)
3032              
3033             # one member of Tag-team
3034             #
3035             # P.128 Start of match (or end of previous match): \G
3036             # P.130 Advanced Use of \G with Perl
3037             # in Chapter 3: Overview of Regular Expression Features and Flavors
3038             # P.255 Use leading anchors
3039             # P.256 Expose ^ and \G at the front expressions
3040             # in Chapter 6: Crafting an Efficient Expression
3041             # P.315 "Tag-team" matching with /gc
3042             # in Chapter 7: Perl
3043 204         390 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3044 204         404  
3045 204         1005 my $e_script = '';
3046             while (not /\G \z/oxgc) { # member
3047             $e_script .= Latin6::escape_token();
3048 75097         115198 }
3049              
3050             return $e_script;
3051             }
3052              
3053             #
3054             # escape Latin-6 token of script
3055             #
3056             sub Latin6::escape_token {
3057              
3058 204     75097 0 3079 # \n output here document
3059              
3060             my $ignore_modules = join('|', qw(
3061             utf8
3062             bytes
3063             charnames
3064             I18N::Japanese
3065             I18N::Collate
3066             I18N::JExt
3067             File::DosGlob
3068             Wild
3069             Wildcard
3070             Japanese
3071             ));
3072              
3073             # another member of Tag-team
3074             #
3075             # P.315 "Tag-team" matching with /gc
3076             # in Chapter 7: Perl
3077 75097 100 100     92829 # 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          
3078 75097         3050851  
3079 12544 100       15969 if (/\G ( \n ) /oxgc) { # another member (and so on)
3080 12544         33729 my $heredoc = '';
3081             if (scalar(@heredoc_delimiter) >= 1) {
3082 174         235 $slash = 'm//';
3083 174         359  
3084             $heredoc = join '', @heredoc;
3085             @heredoc = ();
3086 174         316  
3087 174         307 # skip here document
3088             for my $heredoc_delimiter (@heredoc_delimiter) {
3089 174         1267 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3090             }
3091 174         313 @heredoc_delimiter = ();
3092              
3093 174         268 $here_script = '';
3094             }
3095             return "\n" . $heredoc;
3096             }
3097 12544         45812  
3098             # ignore space, comment
3099             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3100              
3101             # if (, elsif (, unless (, while (, until (, given (, and when (
3102              
3103             # given, when
3104              
3105             # P.225 The given Statement
3106             # in Chapter 15: Smart Matching and given-when
3107             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3108              
3109             # P.133 The given Statement
3110             # in Chapter 4: Statements and Declarations
3111             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3112 18084         55762  
3113 1401         2183 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3114             $slash = 'm//';
3115             return $1;
3116             }
3117              
3118             # scalar variable ($scalar = ...) =~ tr///;
3119             # scalar variable ($scalar = ...) =~ s///;
3120              
3121             # state
3122              
3123             # P.68 Persistent, Private Variables
3124             # in Chapter 4: Subroutines
3125             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3126              
3127             # P.160 Persistent Lexically Scoped Variables: state
3128             # in Chapter 4: Statements and Declarations
3129             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3130              
3131             # (and so on)
3132 1401         4750  
3133             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3134 86 50       173 my $e_string = e_string($1);
    50          
3135 86         1976  
3136 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3137 0         0 $tr_variable = $e_string . e_string($1);
3138 0         0 $bind_operator = $2;
3139             $slash = 'm//';
3140             return '';
3141 0         0 }
3142 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3143 0         0 $sub_variable = $e_string . e_string($1);
3144 0         0 $bind_operator = $2;
3145             $slash = 'm//';
3146             return '';
3147 0         0 }
3148 86         155 else {
3149             $slash = 'div';
3150             return $e_string;
3151             }
3152             }
3153              
3154 86         281 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
3155 4         9 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3156             $slash = 'div';
3157             return q{Elatin6::PREMATCH()};
3158             }
3159              
3160 4         13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
3161 28         52 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3162             $slash = 'div';
3163             return q{Elatin6::MATCH()};
3164             }
3165              
3166 28         84 # $', ${'} --> $', ${'}
3167 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3168             $slash = 'div';
3169             return $1;
3170             }
3171              
3172 1         5 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
3173 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3174             $slash = 'div';
3175             return q{Elatin6::POSTMATCH()};
3176             }
3177              
3178             # scalar variable $scalar =~ tr///;
3179             # scalar variable $scalar =~ s///;
3180             # substr() =~ tr///;
3181 3         10 # substr() =~ s///;
3182             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3183 1671 100       3591 my $scalar = e_string($1);
    100          
3184 1671         6872  
3185 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3186 1         3 $tr_variable = $scalar;
3187 1         2 $bind_operator = $1;
3188             $slash = 'm//';
3189             return '';
3190 1         3 }
3191 61         122 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3192 61         178 $sub_variable = $scalar;
3193 61         97 $bind_operator = $1;
3194             $slash = 'm//';
3195             return '';
3196 61         196 }
3197 1609         2199 else {
3198             $slash = 'div';
3199             return $scalar;
3200             }
3201             }
3202              
3203 1609         4197 # end of statement
3204             elsif (/\G ( [,;] ) /oxgc) {
3205             $slash = 'm//';
3206 5020         7666  
3207             # clear tr/// variable
3208             $tr_variable = '';
3209 5020         6021  
3210             # clear s/// variable
3211 5020         6011 $sub_variable = '';
3212              
3213 5020         6389 $bind_operator = '';
3214              
3215             return $1;
3216             }
3217              
3218 5020         16944 # bareword
3219             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3220             return $1;
3221             }
3222              
3223 0         0 # $0 --> $0
3224 2         4 elsif (/\G ( \$ 0 ) /oxmsgc) {
3225             $slash = 'div';
3226             return $1;
3227 2         8 }
3228 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3229             $slash = 'div';
3230             return $1;
3231             }
3232              
3233 0         0 # $$ --> $$
3234 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3235             $slash = 'div';
3236             return $1;
3237             }
3238              
3239             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3240 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3241 4         5 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3242             $slash = 'div';
3243             return e_capture($1);
3244 4         9 }
3245 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3246             $slash = 'div';
3247             return e_capture($1);
3248             }
3249              
3250 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3251 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3252             $slash = 'div';
3253             return e_capture($1.'->'.$2);
3254             }
3255              
3256 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3257 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3258             $slash = 'div';
3259             return e_capture($1.'->'.$2);
3260             }
3261              
3262 0         0 # $$foo
3263 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3264             $slash = 'div';
3265             return e_capture($1);
3266             }
3267              
3268 0         0 # ${ foo }
3269 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3270             $slash = 'div';
3271             return '${' . $1 . '}';
3272             }
3273              
3274 0         0 # ${ ... }
3275 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3276             $slash = 'div';
3277             return e_capture($1);
3278             }
3279              
3280             # variable or function
3281 0         0 # $ @ % & * $ #
3282 42         97 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) {
3283             $slash = 'div';
3284             return $1;
3285             }
3286             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3287 42         142 # $ @ # \ ' " / ? ( ) [ ] < >
3288 62         123 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3289             $slash = 'div';
3290             return $1;
3291             }
3292              
3293 62         206 # while ()
3294             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3295             return $1;
3296             }
3297              
3298             # while () --- glob
3299              
3300             # avoid "Error: Runtime exception" of perl version 5.005_03
3301 0         0  
3302             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3303             return 'while ($_ = Elatin6::glob("' . $1 . '"))';
3304             }
3305              
3306 0         0 # while (glob)
3307             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3308             return 'while ($_ = Elatin6::glob_)';
3309             }
3310              
3311 0         0 # while (glob(WILDCARD))
3312             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3313             return 'while ($_ = Elatin6::glob';
3314             }
3315 0         0  
  248         527  
3316             # doit if, doit unless, doit while, doit until, doit for, doit when
3317             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3318 248         850  
  19         41  
3319 19         65 # subroutines of package Elatin6
  0         0  
3320 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         22  
3321 13         33 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3322 0         0 elsif (/\G \b Latin6::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         171  
3323 114         335 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         50  
3324 2         10 elsif (/\G \b Latin6::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin6::escape'; }
  0         0  
3325 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3326 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::chop'; }
  0         0  
3327 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3328 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3329 0         0 elsif (/\G \b Latin6::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin6::index'; }
  2         4  
3330 2         6 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::index'; }
  0         0  
3331 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3332 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3333 0         0 elsif (/\G \b Latin6::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin6::rindex'; }
  1         2  
3334 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::rindex'; }
  0         0  
3335 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::lc'; }
  1         3  
3336 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::lcfirst'; }
  0         0  
3337 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::uc'; }
  6         11  
3338             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::ucfirst'; }
3339             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::fc'; }
3340 6         15  
  0         0  
3341 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3342 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3343 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3344 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3345 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3346 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3347             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3348 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  
3349 0         0  
  0         0  
3350 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3351 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3352 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3353 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3354 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3355             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3356             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3357 0         0  
  0         0  
3358 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3359 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3360 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3361             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3362 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         3  
3363 2         36  
  2         4  
3364 2         8 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         84  
3365 36         108 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3366 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::chr'; }
  8         12  
3367 8         28 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3368 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3369 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::glob'; }
  0         0  
3370 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::lc_'; }
  0         0  
3371 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::lcfirst_'; }
  0         0  
3372 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::uc_'; }
  0         0  
3373 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::ucfirst_'; }
  0         0  
3374             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::fc_'; }
3375 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3376 0         0  
  0         0  
3377 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3378 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3379 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::chr_'; }
  0         0  
3380 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3381 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3382 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::glob_'; }
  8         23  
3383             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3384             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3385 8         81 # split
3386             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3387 87         185 $slash = 'm//';
3388 87         137  
3389 87         319 my $e = '';
3390             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3391             $e .= $1;
3392             }
3393 85 100       318  
  87 100       6469  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3394             # end of split
3395             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin6::split' . $e; }
3396 2         8  
3397             # split scalar value
3398             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin6::split' . $e . e_string($1); }
3399 1         7  
3400 0         0 # split literal space
3401 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin6::split' . $e . qq {qq$1 $2}; }
3402 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3403 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3404 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3405 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3406 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3407 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin6::split' . $e . qq {q$1 $2}; }
3408 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3409 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3410 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3411 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3412 10         51 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3413             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin6::split' . $e . qq {' '}; }
3414             elsif (/\G " [ ] " /oxgc) { return 'Elatin6::split' . $e . qq {" "}; }
3415              
3416 0 0       0 # split qq//
  0         0  
3417             elsif (/\G \b (qq) \b /oxgc) {
3418 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3419 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3420 0         0 while (not /\G \z/oxgc) {
3421 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3422 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3423 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3424 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3425 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3426             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3427 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3428             }
3429             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3430             }
3431             }
3432              
3433 0 50       0 # split qr//
  12         438  
3434             elsif (/\G \b (qr) \b /oxgc) {
3435 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3436 12 50       62 else {
  12 50       4184  
    50          
    50          
    50          
    50          
    50          
    50          
3437 0         0 while (not /\G \z/oxgc) {
3438 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3439 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3440 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3441 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3442 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3443 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3444             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3445 12         84 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3446             }
3447             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3448             }
3449             }
3450              
3451 0 0       0 # split q//
  0         0  
3452             elsif (/\G \b (q) \b /oxgc) {
3453 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3454 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3455 0         0 while (not /\G \z/oxgc) {
3456 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3457 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3458 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3459 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3460 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3461             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3462 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3463             }
3464             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3465             }
3466             }
3467              
3468 0 50       0 # split m//
  18         465  
3469             elsif (/\G \b (m) \b /oxgc) {
3470 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3471 18 50       88 else {
  18 50       3698  
    50          
    50          
    50          
    50          
    50          
    50          
3472 0         0 while (not /\G \z/oxgc) {
3473 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3474 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3475 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3476 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3477 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3478 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3479             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3480 18         118 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3481             }
3482             die __FILE__, ": Search pattern not terminated\n";
3483             }
3484             }
3485              
3486 0         0 # split ''
3487 0         0 elsif (/\G (\') /oxgc) {
3488 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3489 0         0 while (not /\G \z/oxgc) {
3490 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3491 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3492             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3493 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3494             }
3495             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3496             }
3497              
3498 0         0 # split ""
3499 0         0 elsif (/\G (\") /oxgc) {
3500 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3501 0         0 while (not /\G \z/oxgc) {
3502 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3503 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3504             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3505 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3506             }
3507             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3508             }
3509              
3510 0         0 # split //
3511 44         116 elsif (/\G (\/) /oxgc) {
3512 44 50       176 my $regexp = '';
  381 50       1520  
    100          
    50          
3513 0         0 while (not /\G \z/oxgc) {
3514 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3515 44         221 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3516             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3517 337         665 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3518             }
3519             die __FILE__, ": Search pattern not terminated\n";
3520             }
3521             }
3522              
3523             # tr/// or y///
3524              
3525             # about [cdsrbB]* (/B modifier)
3526             #
3527             # P.559 appendix C
3528             # of ISBN 4-89052-384-7 Programming perl
3529             # (Japanese title is: Perl puroguramingu)
3530 0         0  
3531             elsif (/\G \b ( tr | y ) \b /oxgc) {
3532             my $ope = $1;
3533 3 50       7  
3534 3         70 # $1 $2 $3 $4 $5 $6
3535 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3536             my @tr = ($tr_variable,$2);
3537             return e_tr(@tr,'',$4,$6);
3538 0         0 }
3539 3         7 else {
3540 3 50       8 my $e = '';
  3 50       232  
    50          
    50          
    50          
    50          
3541             while (not /\G \z/oxgc) {
3542 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3543 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3544 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3545 0         0 while (not /\G \z/oxgc) {
3546 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3547 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3548 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3549 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3550             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3551 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3552             }
3553             die __FILE__, ": Transliteration replacement not terminated\n";
3554 0         0 }
3555 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3556 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3557 0         0 while (not /\G \z/oxgc) {
3558 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3559 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3560 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3561 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3562             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3563 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3564             }
3565             die __FILE__, ": Transliteration replacement not terminated\n";
3566 0         0 }
3567 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3568 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3569 0         0 while (not /\G \z/oxgc) {
3570 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3571 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3572 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3573 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3574             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3575 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3576             }
3577             die __FILE__, ": Transliteration replacement not terminated\n";
3578 0         0 }
3579 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3580 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3581 0         0 while (not /\G \z/oxgc) {
3582 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3583 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3584 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3585 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3586             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3587 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3588             }
3589             die __FILE__, ": Transliteration replacement not terminated\n";
3590             }
3591 0         0 # $1 $2 $3 $4 $5 $6
3592 3         13 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3593             my @tr = ($tr_variable,$2);
3594             return e_tr(@tr,'',$4,$6);
3595 3         8 }
3596             }
3597             die __FILE__, ": Transliteration pattern not terminated\n";
3598             }
3599             }
3600              
3601 0         0 # qq//
3602             elsif (/\G \b (qq) \b /oxgc) {
3603             my $ope = $1;
3604 2180 50       8256  
3605 2180         4080 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3606 0         0 if (/\G (\#) /oxgc) { # qq# #
3607 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3608 0         0 while (not /\G \z/oxgc) {
3609 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3610 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3611             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3612 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3613             }
3614             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3615             }
3616 0         0  
3617 2180         2939 else {
3618 2180 50       5050 my $e = '';
  2180 50       8164  
    100          
    50          
    50          
    0          
3619             while (not /\G \z/oxgc) {
3620             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3621              
3622 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3623 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3624 0         0 my $qq_string = '';
3625 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3626 0         0 while (not /\G \z/oxgc) {
3627 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3628             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3629 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3630 0         0 elsif (/\G (\)) /oxgc) {
3631             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3632 0         0 else { $qq_string .= $1; }
3633             }
3634 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3635             }
3636             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3637             }
3638              
3639 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3640 2150         2701 elsif (/\G (\{) /oxgc) { # qq { }
3641 2150         2906 my $qq_string = '';
3642 2150 100       4409 local $nest = 1;
  84006 50       280183  
    100          
    100          
    50          
3643 722         1377 while (not /\G \z/oxgc) {
3644 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1633  
3645             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3646 1153 100       2406 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5123  
3647 2150         4844 elsif (/\G (\}) /oxgc) {
3648             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3649 1153         2551 else { $qq_string .= $1; }
3650             }
3651 78828         172688 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3652             }
3653             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3654             }
3655              
3656 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3657 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3658 0         0 my $qq_string = '';
3659 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3660 0         0 while (not /\G \z/oxgc) {
3661 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3662             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3663 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3664 0         0 elsif (/\G (\]) /oxgc) {
3665             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3666 0         0 else { $qq_string .= $1; }
3667             }
3668 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3669             }
3670             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3671             }
3672              
3673 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3674 30         57 elsif (/\G (\<) /oxgc) { # qq < >
3675 30         64 my $qq_string = '';
3676 30 100       102 local $nest = 1;
  1166 50       3963  
    50          
    100          
    50          
3677 22         49 while (not /\G \z/oxgc) {
3678 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3679             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3680 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         65  
3681 30         65 elsif (/\G (\>) /oxgc) {
3682             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3683 0         0 else { $qq_string .= $1; }
3684             }
3685 1114         2190 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3686             }
3687             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3688             }
3689              
3690 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3691 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3692 0         0 my $delimiter = $1;
3693 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3694 0         0 while (not /\G \z/oxgc) {
3695 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3696 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3697             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3698 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3699             }
3700             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3701 0         0 }
3702             }
3703             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3704             }
3705             }
3706              
3707 0         0 # qr//
3708 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3709 0         0 my $ope = $1;
3710             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3711             return e_qr($ope,$1,$3,$2,$4);
3712 0         0 }
3713 0         0 else {
3714 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3715 0         0 while (not /\G \z/oxgc) {
3716 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3717 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3718 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3719 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3720 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3721 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3722             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3723 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3724             }
3725             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3726             }
3727             }
3728              
3729 0         0 # qw//
3730 16 50       49 elsif (/\G \b (qw) \b /oxgc) {
3731 16         57 my $ope = $1;
3732             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3733             return e_qw($ope,$1,$3,$2);
3734 0         0 }
3735 16         37 else {
3736 16 50       78 my $e = '';
  16 50       293  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3737             while (not /\G \z/oxgc) {
3738 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3739 16         79  
3740             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3741 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3742 0         0  
3743             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3744 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3745 0         0  
3746             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3747 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3748 0         0  
3749             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3750 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3751 0         0  
3752             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3753 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3754             }
3755             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3756             }
3757             }
3758              
3759 0         0 # qx//
3760 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3761 0         0 my $ope = $1;
3762             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3763             return e_qq($ope,$1,$3,$2);
3764 0         0 }
3765 0         0 else {
3766 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3767 0         0 while (not /\G \z/oxgc) {
3768 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3769 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3770 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3771 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3772 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3773             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3774 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3775             }
3776             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3777             }
3778             }
3779              
3780 0         0 # q//
3781             elsif (/\G \b (q) \b /oxgc) {
3782             my $ope = $1;
3783              
3784             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3785              
3786             # avoid "Error: Runtime exception" of perl version 5.005_03
3787 410 50       1018 # (and so on)
3788 410         1146  
3789 0         0 if (/\G (\#) /oxgc) { # q# #
3790 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3791 0         0 while (not /\G \z/oxgc) {
3792 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3793 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3794             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3795 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3796             }
3797             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3798             }
3799 0         0  
3800 410         665 else {
3801 410 50       1272 my $e = '';
  410 50       2115  
    100          
    50          
    100          
    50          
3802             while (not /\G \z/oxgc) {
3803             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3804              
3805 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3806 0         0 elsif (/\G (\() /oxgc) { # q ( )
3807 0         0 my $q_string = '';
3808 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3809 0         0 while (not /\G \z/oxgc) {
3810 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3811 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3812             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3813 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3814 0         0 elsif (/\G (\)) /oxgc) {
3815             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3816 0         0 else { $q_string .= $1; }
3817             }
3818 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3819             }
3820             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3821             }
3822              
3823 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3824 404         769 elsif (/\G (\{) /oxgc) { # q { }
3825 404         641 my $q_string = '';
3826 404 50       1042 local $nest = 1;
  6770 50       24137  
    50          
    100          
    100          
    50          
3827 0         0 while (not /\G \z/oxgc) {
3828 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3829 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         182  
3830             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3831 107 100       187 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1104  
3832 404         1040 elsif (/\G (\}) /oxgc) {
3833             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3834 107         212 else { $q_string .= $1; }
3835             }
3836 6152         11580 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3837             }
3838             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3839             }
3840              
3841 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3842 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3843 0         0 my $q_string = '';
3844 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3845 0         0 while (not /\G \z/oxgc) {
3846 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3847 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3848             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3849 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3850 0         0 elsif (/\G (\]) /oxgc) {
3851             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3852 0         0 else { $q_string .= $1; }
3853             }
3854 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3855             }
3856             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3857             }
3858              
3859 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3860 5         12 elsif (/\G (\<) /oxgc) { # q < >
3861 5         13 my $q_string = '';
3862 5 50       19 local $nest = 1;
  88 50       559  
    50          
    50          
    100          
    50          
3863 0         0 while (not /\G \z/oxgc) {
3864 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3865 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3866             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3867 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         15  
3868 5         24 elsif (/\G (\>) /oxgc) {
3869             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3870 0         0 else { $q_string .= $1; }
3871             }
3872 83         159 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3873             }
3874             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3875             }
3876              
3877 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3878 1         2 elsif (/\G (\S) /oxgc) { # q * *
3879 1         1 my $delimiter = $1;
3880 1 50       4 my $q_string = '';
  14 50       60  
    100          
    50          
3881 0         0 while (not /\G \z/oxgc) {
3882 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3883 1         4 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3884             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3885 13         27 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3886             }
3887             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3888 0         0 }
3889             }
3890             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3891             }
3892             }
3893              
3894 0         0 # m//
3895 209 50       546 elsif (/\G \b (m) \b /oxgc) {
3896 209         1469 my $ope = $1;
3897             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3898             return e_qr($ope,$1,$3,$2,$4);
3899 0         0 }
3900 209         369 else {
3901 209 50       691 my $e = '';
  209 50       10353  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3902 0         0 while (not /\G \z/oxgc) {
3903 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3904 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3905 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3906 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3907 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3908 10         25 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3909 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3910             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3911 199         754 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3912             }
3913             die __FILE__, ": Search pattern not terminated\n";
3914             }
3915             }
3916              
3917             # s///
3918              
3919             # about [cegimosxpradlunbB]* (/cg modifier)
3920             #
3921             # P.67 Pattern-Matching Operators
3922             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3923 0         0  
3924             elsif (/\G \b (s) \b /oxgc) {
3925             my $ope = $1;
3926 97 100       254  
3927 97         1853 # $1 $2 $3 $4 $5 $6
3928             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3929             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3930 1         5 }
3931 96         173 else {
3932 96 50       269 my $e = '';
  96 50       12523  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3933             while (not /\G \z/oxgc) {
3934 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3935 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3936 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3937             while (not /\G \z/oxgc) {
3938 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3939 0         0 # $1 $2 $3 $4
3940 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949             }
3950             die __FILE__, ": Substitution replacement not terminated\n";
3951 0         0 }
3952 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3953 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3954             while (not /\G \z/oxgc) {
3955 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3956 0         0 # $1 $2 $3 $4
3957 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966             }
3967             die __FILE__, ": Substitution replacement not terminated\n";
3968 0         0 }
3969 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3970 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3971             while (not /\G \z/oxgc) {
3972 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3973 0         0 # $1 $2 $3 $4
3974 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981             }
3982             die __FILE__, ": Substitution replacement not terminated\n";
3983 0         0 }
3984 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3985 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3986             while (not /\G \z/oxgc) {
3987 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3988 0         0 # $1 $2 $3 $4
3989 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3990 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3991 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3992 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3993 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3994 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3995 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3997 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3998             }
3999             die __FILE__, ": Substitution replacement not terminated\n";
4000             }
4001 0         0 # $1 $2 $3 $4 $5 $6
4002             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4003             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4004             }
4005 21         70 # $1 $2 $3 $4 $5 $6
4006             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4007             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4008             }
4009 0         0 # $1 $2 $3 $4 $5 $6
4010             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4011             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4012             }
4013 0         0 # $1 $2 $3 $4 $5 $6
4014             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4015             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4016 75         339 }
4017             }
4018             die __FILE__, ": Substitution pattern not terminated\n";
4019             }
4020             }
4021 0         0  
4022 0         0 # require ignore module
4023 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4024             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4025             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4026 0         0  
4027 37         306 # use strict; --> use strict; no strict qw(refs);
4028 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4029             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4030             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4031              
4032 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4033 2         21 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4034             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4035             return "use $1; no strict qw(refs);";
4036 0         0 }
4037             else {
4038             return "use $1;";
4039             }
4040 2 0 0     12 }
      0        
4041 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4042             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4043             return "use $1; no strict qw(refs);";
4044 0         0 }
4045             else {
4046             return "use $1;";
4047             }
4048             }
4049 0         0  
4050 2         13 # ignore use module
4051 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4052             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4053             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4054 0         0  
4055 0         0 # ignore no module
4056 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4057             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4058             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4059 0         0  
4060             # use else
4061             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4062 0         0  
4063             # use else
4064             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4065              
4066 2         17 # ''
4067 848         1940 elsif (/\G (?
4068 848 100       2130 my $q_string = '';
  8254 100       25580  
    100          
    50          
4069 4         11 while (not /\G \z/oxgc) {
4070 48         162 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4071 848         1852 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4072             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4073 7354         15129 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4074             }
4075             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4076             }
4077              
4078 0         0 # ""
4079 1848         3587 elsif (/\G (\") /oxgc) {
4080 1848 100       5027 my $qq_string = '';
  35409 100       121418  
    100          
    50          
4081 67         147 while (not /\G \z/oxgc) {
4082 12         26 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4083 1848         4310 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4084             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4085 33482         68295 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4086             }
4087             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4088             }
4089              
4090 0         0 # ``
4091 1         2 elsif (/\G (\`) /oxgc) {
4092 1 50       4 my $qx_string = '';
  19 50       67  
    100          
    50          
4093 0         0 while (not /\G \z/oxgc) {
4094 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4095 1         2 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4096             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4097 18         35 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4098             }
4099             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4100             }
4101              
4102 0         0 # // --- not divide operator (num / num), not defined-or
4103 453         1462 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4104 453 50       1424 my $regexp = '';
  4496 50       17109  
    100          
    50          
4105 0         0 while (not /\G \z/oxgc) {
4106 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4107 453         1849 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4108             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4109 4043         9589 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4110             }
4111             die __FILE__, ": Search pattern not terminated\n";
4112             }
4113              
4114 0         0 # ?? --- not conditional operator (condition ? then : else)
4115 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4116 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4117 0         0 while (not /\G \z/oxgc) {
4118 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4119 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4120             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4121 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4122             }
4123             die __FILE__, ": Search pattern not terminated\n";
4124             }
4125 0         0  
  0         0  
4126             # <<>> (a safer ARGV)
4127             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4128 0         0  
  0         0  
4129             # << (bit shift) --- not here document
4130             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4131              
4132 0         0 # <<~'HEREDOC'
4133 6         11 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4134 6         11 $slash = 'm//';
4135             my $here_quote = $1;
4136             my $delimiter = $2;
4137 6 50       10  
4138 6         12 # get here document
4139 6         30 if ($here_script eq '') {
4140             $here_script = CORE::substr $_, pos $_;
4141 6 50       32 $here_script =~ s/.*?\n//oxm;
4142 6         66 }
4143 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4144 6         10 my $heredoc = $1;
4145 6         47 my $indent = $2;
4146 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
4147             push @heredoc, $heredoc . qq{\n$delimiter\n};
4148             push @heredoc_delimiter, qq{\\s*$delimiter};
4149 6         15 }
4150             else {
4151 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4152             }
4153             return qq{<<'$delimiter'};
4154             }
4155              
4156             # <<~\HEREDOC
4157              
4158             # P.66 2.6.6. "Here" Documents
4159             # in Chapter 2: Bits and Pieces
4160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4161              
4162             # P.73 "Here" Documents
4163             # in Chapter 2: Bits and Pieces
4164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4165 6         23  
4166 3         6 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4167 3         10 $slash = 'm//';
4168             my $here_quote = $1;
4169             my $delimiter = $2;
4170 3 50       7  
4171 3         9 # get here document
4172 3         12 if ($here_script eq '') {
4173             $here_script = CORE::substr $_, pos $_;
4174 3 50       29 $here_script =~ s/.*?\n//oxm;
4175 3         51 }
4176 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4177 3         4 my $heredoc = $1;
4178 3         43 my $indent = $2;
4179 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
4180             push @heredoc, $heredoc . qq{\n$delimiter\n};
4181             push @heredoc_delimiter, qq{\\s*$delimiter};
4182 3         10 }
4183             else {
4184 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4185             }
4186             return qq{<<\\$delimiter};
4187             }
4188              
4189 3         12 # <<~"HEREDOC"
4190 6         160 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4191 6         13 $slash = 'm//';
4192             my $here_quote = $1;
4193             my $delimiter = $2;
4194 6 50       14  
4195 6         16 # get here document
4196 6         41 if ($here_script eq '') {
4197             $here_script = CORE::substr $_, pos $_;
4198 6 50       41 $here_script =~ s/.*?\n//oxm;
4199 6         74 }
4200 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4201 6         8 my $heredoc = $1;
4202 6         57 my $indent = $2;
4203 6         21 $heredoc =~ s{^$indent}{}msg; # no /ox
4204             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4205             push @heredoc_delimiter, qq{\\s*$delimiter};
4206 6         585 }
4207             else {
4208 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4209             }
4210             return qq{<<"$delimiter"};
4211             }
4212              
4213 6         35 # <<~HEREDOC
4214 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4215 3         7 $slash = 'm//';
4216             my $here_quote = $1;
4217             my $delimiter = $2;
4218 3 50       6  
4219 3         9 # get here document
4220 3         11 if ($here_script eq '') {
4221             $here_script = CORE::substr $_, pos $_;
4222 3 50       26 $here_script =~ s/.*?\n//oxm;
4223 3         40 }
4224 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4225 3         5 my $heredoc = $1;
4226 3         39 my $indent = $2;
4227 3         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4228             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4229             push @heredoc_delimiter, qq{\\s*$delimiter};
4230 3         11 }
4231             else {
4232 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4233             }
4234             return qq{<<$delimiter};
4235             }
4236              
4237 3         17 # <<~`HEREDOC`
4238 6         16 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4239 6         13 $slash = 'm//';
4240             my $here_quote = $1;
4241             my $delimiter = $2;
4242 6 50       14  
4243 6         14 # get here document
4244 6         19 if ($here_script eq '') {
4245             $here_script = CORE::substr $_, pos $_;
4246 6 50       42 $here_script =~ s/.*?\n//oxm;
4247 6         64 }
4248 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4249 6         11 my $heredoc = $1;
4250 6         55 my $indent = $2;
4251 6         19 $heredoc =~ s{^$indent}{}msg; # no /ox
4252             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4253             push @heredoc_delimiter, qq{\\s*$delimiter};
4254 6         17 }
4255             else {
4256 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4257             }
4258             return qq{<<`$delimiter`};
4259             }
4260              
4261 6         28 # <<'HEREDOC'
4262 72         145 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4263 72         162 $slash = 'm//';
4264             my $here_quote = $1;
4265             my $delimiter = $2;
4266 72 50       122  
4267 72         142 # get here document
4268 72         359 if ($here_script eq '') {
4269             $here_script = CORE::substr $_, pos $_;
4270 72 50       464 $here_script =~ s/.*?\n//oxm;
4271 72         561 }
4272 72         238 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4273             push @heredoc, $1 . qq{\n$delimiter\n};
4274             push @heredoc_delimiter, $delimiter;
4275 72         270 }
4276             else {
4277 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4278             }
4279             return $here_quote;
4280             }
4281              
4282             # <<\HEREDOC
4283              
4284             # P.66 2.6.6. "Here" Documents
4285             # in Chapter 2: Bits and Pieces
4286             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4287              
4288             # P.73 "Here" Documents
4289             # in Chapter 2: Bits and Pieces
4290             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4291 72         292  
4292 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4293 0         0 $slash = 'm//';
4294             my $here_quote = $1;
4295             my $delimiter = $2;
4296 0 0       0  
4297 0         0 # get here document
4298 0         0 if ($here_script eq '') {
4299             $here_script = CORE::substr $_, pos $_;
4300 0 0       0 $here_script =~ s/.*?\n//oxm;
4301 0         0 }
4302 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4303             push @heredoc, $1 . qq{\n$delimiter\n};
4304             push @heredoc_delimiter, $delimiter;
4305 0         0 }
4306             else {
4307 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4308             }
4309             return $here_quote;
4310             }
4311              
4312 0         0 # <<"HEREDOC"
4313 36         96 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4314 36         90 $slash = 'm//';
4315             my $here_quote = $1;
4316             my $delimiter = $2;
4317 36 50       64  
4318 36         91 # get here document
4319 36         1386 if ($here_script eq '') {
4320             $here_script = CORE::substr $_, pos $_;
4321 36 50       220 $here_script =~ s/.*?\n//oxm;
4322 36         457 }
4323 36         117 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4324             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4325             push @heredoc_delimiter, $delimiter;
4326 36         82 }
4327             else {
4328 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4329             }
4330             return $here_quote;
4331             }
4332              
4333 36         143 # <
4334 42         97 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4335 42         85 $slash = 'm//';
4336             my $here_quote = $1;
4337             my $delimiter = $2;
4338 42 50       76  
4339 42         98 # get here document
4340 42         290 if ($here_script eq '') {
4341             $here_script = CORE::substr $_, pos $_;
4342 42 50       336 $here_script =~ s/.*?\n//oxm;
4343 42         563 }
4344 42         150 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4345             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4346             push @heredoc_delimiter, $delimiter;
4347 42         95 }
4348             else {
4349 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4350             }
4351             return $here_quote;
4352             }
4353              
4354 42         169 # <<`HEREDOC`
4355 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4356 0         0 $slash = 'm//';
4357             my $here_quote = $1;
4358             my $delimiter = $2;
4359 0 0       0  
4360 0         0 # get here document
4361 0         0 if ($here_script eq '') {
4362             $here_script = CORE::substr $_, pos $_;
4363 0 0       0 $here_script =~ s/.*?\n//oxm;
4364 0         0 }
4365 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4366             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4367             push @heredoc_delimiter, $delimiter;
4368 0         0 }
4369             else {
4370 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4371             }
4372             return $here_quote;
4373             }
4374              
4375 0         0 # <<= <=> <= < operator
4376             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4377             return $1;
4378             }
4379              
4380 12         64 #
4381             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4382             return $1;
4383             }
4384              
4385             # --- glob
4386              
4387             # avoid "Error: Runtime exception" of perl version 5.005_03
4388 0         0  
4389             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4390             return 'Elatin6::glob("' . $1 . '")';
4391             }
4392 0         0  
4393             # __DATA__
4394             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4395 0         0  
4396             # __END__
4397             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4398              
4399             # \cD Control-D
4400              
4401             # P.68 2.6.8. Other Literal Tokens
4402             # in Chapter 2: Bits and Pieces
4403             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4404              
4405             # P.76 Other Literal Tokens
4406             # in Chapter 2: Bits and Pieces
4407 204         1436 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4408              
4409             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4410 0         0  
4411             # \cZ Control-Z
4412             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4413              
4414             # any operator before div
4415             elsif (/\G (
4416             -- | \+\+ |
4417 0         0 [\)\}\]]
  5081         11024  
4418              
4419             ) /oxgc) { $slash = 'div'; return $1; }
4420              
4421             # yada-yada or triple-dot operator
4422             elsif (/\G (
4423 5081         23296 \.\.\.
  7         14  
4424              
4425             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4426              
4427             # any operator before m//
4428              
4429             # //, //= (defined-or)
4430              
4431             # P.164 Logical Operators
4432             # in Chapter 10: More Control Structures
4433             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4434              
4435             # P.119 C-Style Logical (Short-Circuit) Operators
4436             # in Chapter 3: Unary and Binary Operators
4437             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4438              
4439             # (and so on)
4440              
4441             # ~~
4442              
4443             # P.221 The Smart Match Operator
4444             # in Chapter 15: Smart Matching and given-when
4445             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4446              
4447             # P.112 Smartmatch Operator
4448             # in Chapter 3: Unary and Binary Operators
4449             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4450              
4451             # (and so on)
4452              
4453             elsif (/\G ((?>
4454              
4455             !~~ | !~ | != | ! |
4456             %= | % |
4457             &&= | && | &= | &\.= | &\. | & |
4458             -= | -> | - |
4459             :(?>\s*)= |
4460             : |
4461             <<>> |
4462             <<= | <=> | <= | < |
4463             == | => | =~ | = |
4464             >>= | >> | >= | > |
4465             \*\*= | \*\* | \*= | \* |
4466             \+= | \+ |
4467             \.\. | \.= | \. |
4468             \/\/= | \/\/ |
4469             \/= | \/ |
4470             \? |
4471             \\ |
4472             \^= | \^\.= | \^\. | \^ |
4473             \b x= |
4474             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4475             ~~ | ~\. | ~ |
4476             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4477             \b(?: print )\b |
4478              
4479 7         24 [,;\(\{\[]
  8868         16909  
4480              
4481             )) /oxgc) { $slash = 'm//'; return $1; }
4482 8868         41129  
  15137         29911  
4483             # other any character
4484             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4485              
4486 15137         69434 # system error
4487             else {
4488             die __FILE__, ": Oops, this shouldn't happen!\n";
4489             }
4490             }
4491              
4492 0     1786 0 0 # escape Latin-6 string
4493 1786         4167 sub e_string {
4494             my($string) = @_;
4495 1786         2723 my $e_string = '';
4496              
4497             local $slash = 'm//';
4498              
4499             # P.1024 Appendix W.10 Multibyte Processing
4500             # of ISBN 1-56592-224-7 CJKV Information Processing
4501 1786         2582 # (and so on)
4502              
4503             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4504 1786 100 66     14947  
4505 1786 50       8177 # without { ... }
4506 1769         3944 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4507             if ($string !~ /<
4508             return $string;
4509             }
4510             }
4511 1769         4442  
4512 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          
4513             while ($string !~ /\G \z/oxgc) {
4514             if (0) {
4515             }
4516 190         11493  
4517 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin6::PREMATCH()]}
4518 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4519             $e_string .= q{Elatin6::PREMATCH()};
4520             $slash = 'div';
4521             }
4522              
4523 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin6::MATCH()]}
4524 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4525             $e_string .= q{Elatin6::MATCH()};
4526             $slash = 'div';
4527             }
4528              
4529 0         0 # $', ${'} --> $', ${'}
4530 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4531             $e_string .= $1;
4532             $slash = 'div';
4533             }
4534              
4535 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin6::POSTMATCH()]}
4536 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4537             $e_string .= q{Elatin6::POSTMATCH()};
4538             $slash = 'div';
4539             }
4540              
4541 0         0 # bareword
4542 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4543             $e_string .= $1;
4544             $slash = 'div';
4545             }
4546              
4547 0         0 # $0 --> $0
4548 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4549             $e_string .= $1;
4550             $slash = 'div';
4551 0         0 }
4552 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4553             $e_string .= $1;
4554             $slash = 'div';
4555             }
4556              
4557 0         0 # $$ --> $$
4558 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4559             $e_string .= $1;
4560             $slash = 'div';
4561             }
4562              
4563             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4564 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4565 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4566             $e_string .= e_capture($1);
4567             $slash = 'div';
4568 0         0 }
4569 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4570             $e_string .= e_capture($1);
4571             $slash = 'div';
4572             }
4573              
4574 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4575 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4576             $e_string .= e_capture($1.'->'.$2);
4577             $slash = 'div';
4578             }
4579              
4580 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4581 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4582             $e_string .= e_capture($1.'->'.$2);
4583             $slash = 'div';
4584             }
4585              
4586 0         0 # $$foo
4587 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4588             $e_string .= e_capture($1);
4589             $slash = 'div';
4590             }
4591              
4592 0         0 # ${ foo }
4593 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4594             $e_string .= '${' . $1 . '}';
4595             $slash = 'div';
4596             }
4597              
4598 0         0 # ${ ... }
4599 3         17 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4600             $e_string .= e_capture($1);
4601             $slash = 'div';
4602             }
4603              
4604             # variable or function
4605 3         38 # $ @ % & * $ #
4606 7         18 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) {
4607             $e_string .= $1;
4608             $slash = 'div';
4609             }
4610             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4611 7         23 # $ @ # \ ' " / ? ( ) [ ] < >
4612 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4613             $e_string .= $1;
4614             $slash = 'div';
4615             }
4616 0         0  
  0         0  
4617 0         0 # subroutines of package Elatin6
  0         0  
4618 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4619 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4620 0         0 elsif ($string =~ /\G \b Latin6::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4621 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4622 0         0 elsif ($string =~ /\G \b Latin6::eval \b /oxgc) { $e_string .= 'eval Latin6::escape'; $slash = 'm//'; }
  0         0  
4623 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4624 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin6::chop'; $slash = 'm//'; }
  0         0  
4625 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4626 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4627 0         0 elsif ($string =~ /\G \b Latin6::index \b /oxgc) { $e_string .= 'Latin6::index'; $slash = 'm//'; }
  0         0  
4628 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin6::index'; $slash = 'm//'; }
  0         0  
4629 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4630 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4631 0         0 elsif ($string =~ /\G \b Latin6::rindex \b /oxgc) { $e_string .= 'Latin6::rindex'; $slash = 'm//'; }
  0         0  
4632 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin6::rindex'; $slash = 'm//'; }
  0         0  
4633 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::lc'; $slash = 'm//'; }
  0         0  
4634 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::lcfirst'; $slash = 'm//'; }
  0         0  
4635 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::uc'; $slash = 'm//'; }
  0         0  
4636             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::ucfirst'; $slash = 'm//'; }
4637             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::fc'; $slash = 'm//'; }
4638 0         0  
  0         0  
4639 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4640 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4641 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  
4642 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  
4643 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  
4644 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  
4645             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4646 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  
4647 0         0  
  0         0  
4648 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4649 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  
4650 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  
4651 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  
4652 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  
4653             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4654             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4655 0         0  
  0         0  
4656 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4657 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4658 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4659             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4660 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4661 0         0  
  0         0  
4662 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4663 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4664 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::chr'; $slash = 'm//'; }
  0         0  
4665 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4666 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4667 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::glob'; $slash = 'm//'; }
  0         0  
4668 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin6::lc_'; $slash = 'm//'; }
  0         0  
4669 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin6::lcfirst_'; $slash = 'm//'; }
  0         0  
4670 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin6::uc_'; $slash = 'm//'; }
  0         0  
4671 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin6::ucfirst_'; $slash = 'm//'; }
  0         0  
4672             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin6::fc_'; $slash = 'm//'; }
4673 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4674 0         0  
  0         0  
4675 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4677 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin6::chr_'; $slash = 'm//'; }
  0         0  
4678 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4679 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4680 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin6::glob_'; $slash = 'm//'; }
  0         0  
4681             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4682             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4683 0         0 # split
4684             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4685 0         0 $slash = 'm//';
4686 0         0  
4687 0         0 my $e = '';
4688             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4689             $e .= $1;
4690             }
4691 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          
4692             # end of split
4693             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin6::split' . $e; }
4694 0         0  
  0         0  
4695             # split scalar value
4696             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin6::split' . $e . e_string($1); next E_STRING_LOOP; }
4697 0         0  
  0         0  
4698 0         0 # split literal space
  0         0  
4699 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4700 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4701 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4702 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4703 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4704 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  
4705 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4706 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4707 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4708 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4709 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4710 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  
4711             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {' '}; next E_STRING_LOOP; }
4712             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {" "}; next E_STRING_LOOP; }
4713              
4714 0 0       0 # split qq//
  0         0  
  0         0  
4715             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4716 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4717 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4718 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4719 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4720 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  
4721 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  
4722 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  
4723 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  
4724             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4725 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 * *
4726             }
4727             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4728             }
4729             }
4730              
4731 0 0       0 # split qr//
  0         0  
  0         0  
4732             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4733 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4734 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4735 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4736 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4737 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  
4738 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  
4739 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  
4740 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  
4741 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  
4742             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4743 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 * *
4744             }
4745             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4746             }
4747             }
4748              
4749 0 0       0 # split q//
  0         0  
  0         0  
4750             elsif ($string =~ /\G \b (q) \b /oxgc) {
4751 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4752 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4753 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4754 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4755 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  
4756 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  
4757 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  
4758 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  
4759             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4760 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 * *
4761             }
4762             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4763             }
4764             }
4765              
4766 0 0       0 # split m//
  0         0  
  0         0  
4767             elsif ($string =~ /\G \b (m) \b /oxgc) {
4768 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 # #
4769 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4770 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4771 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4772 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  
4773 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  
4774 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  
4775 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  
4776 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  
4777             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4778 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 * *
4779             }
4780             die __FILE__, ": Search pattern not terminated\n";
4781             }
4782             }
4783              
4784 0         0 # split ''
4785 0         0 elsif ($string =~ /\G (\') /oxgc) {
4786 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4787 0         0 while ($string !~ /\G \z/oxgc) {
4788 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4789 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4790             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4791 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4792             }
4793             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4794             }
4795              
4796 0         0 # split ""
4797 0         0 elsif ($string =~ /\G (\") /oxgc) {
4798 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4799 0         0 while ($string !~ /\G \z/oxgc) {
4800 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4801 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4802             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4803 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4804             }
4805             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4806             }
4807              
4808 0         0 # split //
4809 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4810 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4811 0         0 while ($string !~ /\G \z/oxgc) {
4812 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4813 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4814             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4815 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4816             }
4817             die __FILE__, ": Search pattern not terminated\n";
4818             }
4819             }
4820              
4821 0         0 # qq//
4822 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4823 0         0 my $ope = $1;
4824             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4825             $e_string .= e_qq($ope,$1,$3,$2);
4826 0         0 }
4827 0         0 else {
4828 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4829 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4830 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4831 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4832 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4833 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4834             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4835 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4836             }
4837             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4838             }
4839             }
4840              
4841 0         0 # qx//
4842 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4843 0         0 my $ope = $1;
4844             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4845             $e_string .= e_qq($ope,$1,$3,$2);
4846 0         0 }
4847 0         0 else {
4848 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4849 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4850 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4851 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4852 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4853 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4854 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4855             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4856 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4857             }
4858             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4859             }
4860             }
4861              
4862 0         0 # q//
4863 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4864 0         0 my $ope = $1;
4865             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4866             $e_string .= e_q($ope,$1,$3,$2);
4867 0         0 }
4868 0         0 else {
4869 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4870 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4871 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4872 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4873 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4874 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4875             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4876 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 * *
4877             }
4878             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4879             }
4880             }
4881 0         0  
4882             # ''
4883             elsif ($string =~ /\G (?
4884 0         0  
4885             # ""
4886             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4887 0         0  
4888             # ``
4889             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4890 0         0  
4891             # <<>> (a safer ARGV)
4892             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4893 0         0  
4894             # <<= <=> <= < operator
4895             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4896 0         0  
4897             #
4898             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4899              
4900 0         0 # --- glob
4901             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4902             $e_string .= 'Elatin6::glob("' . $1 . '")';
4903             }
4904              
4905 0         0 # << (bit shift) --- not here document
4906 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4907             $slash = 'm//';
4908             $e_string .= $1;
4909             }
4910              
4911 0         0 # <<~'HEREDOC'
4912 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4913 0         0 $slash = 'm//';
4914             my $here_quote = $1;
4915             my $delimiter = $2;
4916 0 0       0  
4917 0         0 # get here document
4918 0         0 if ($here_script eq '') {
4919             $here_script = CORE::substr $_, pos $_;
4920 0 0       0 $here_script =~ s/.*?\n//oxm;
4921 0         0 }
4922 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4923 0         0 my $heredoc = $1;
4924 0         0 my $indent = $2;
4925 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4926             push @heredoc, $heredoc . qq{\n$delimiter\n};
4927             push @heredoc_delimiter, qq{\\s*$delimiter};
4928 0         0 }
4929             else {
4930 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4931             }
4932             $e_string .= qq{<<'$delimiter'};
4933             }
4934              
4935 0         0 # <<~\HEREDOC
4936 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4937 0         0 $slash = 'm//';
4938             my $here_quote = $1;
4939             my $delimiter = $2;
4940 0 0       0  
4941 0         0 # get here document
4942 0         0 if ($here_script eq '') {
4943             $here_script = CORE::substr $_, pos $_;
4944 0 0       0 $here_script =~ s/.*?\n//oxm;
4945 0         0 }
4946 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4947 0         0 my $heredoc = $1;
4948 0         0 my $indent = $2;
4949 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4950             push @heredoc, $heredoc . qq{\n$delimiter\n};
4951             push @heredoc_delimiter, qq{\\s*$delimiter};
4952 0         0 }
4953             else {
4954 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4955             }
4956             $e_string .= qq{<<\\$delimiter};
4957             }
4958              
4959 0         0 # <<~"HEREDOC"
4960 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4961 0         0 $slash = 'm//';
4962             my $here_quote = $1;
4963             my $delimiter = $2;
4964 0 0       0  
4965 0         0 # get here document
4966 0         0 if ($here_script eq '') {
4967             $here_script = CORE::substr $_, pos $_;
4968 0 0       0 $here_script =~ s/.*?\n//oxm;
4969 0         0 }
4970 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4971 0         0 my $heredoc = $1;
4972 0         0 my $indent = $2;
4973 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4974             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4975             push @heredoc_delimiter, qq{\\s*$delimiter};
4976 0         0 }
4977             else {
4978 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4979             }
4980             $e_string .= qq{<<"$delimiter"};
4981             }
4982              
4983 0         0 # <<~HEREDOC
4984 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4985 0         0 $slash = 'm//';
4986             my $here_quote = $1;
4987             my $delimiter = $2;
4988 0 0       0  
4989 0         0 # get here document
4990 0         0 if ($here_script eq '') {
4991             $here_script = CORE::substr $_, pos $_;
4992 0 0       0 $here_script =~ s/.*?\n//oxm;
4993 0         0 }
4994 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4995 0         0 my $heredoc = $1;
4996 0         0 my $indent = $2;
4997 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4998             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4999             push @heredoc_delimiter, qq{\\s*$delimiter};
5000 0         0 }
5001             else {
5002 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5003             }
5004             $e_string .= qq{<<$delimiter};
5005             }
5006              
5007 0         0 # <<~`HEREDOC`
5008 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
5009 0         0 $slash = 'm//';
5010             my $here_quote = $1;
5011             my $delimiter = $2;
5012 0 0       0  
5013 0         0 # get here document
5014 0         0 if ($here_script eq '') {
5015             $here_script = CORE::substr $_, pos $_;
5016 0 0       0 $here_script =~ s/.*?\n//oxm;
5017 0         0 }
5018 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5019 0         0 my $heredoc = $1;
5020 0         0 my $indent = $2;
5021 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5022             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5023             push @heredoc_delimiter, qq{\\s*$delimiter};
5024 0         0 }
5025             else {
5026 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5027             }
5028             $e_string .= qq{<<`$delimiter`};
5029             }
5030              
5031 0         0 # <<'HEREDOC'
5032 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5033 0         0 $slash = 'm//';
5034             my $here_quote = $1;
5035             my $delimiter = $2;
5036 0 0       0  
5037 0         0 # get here document
5038 0         0 if ($here_script eq '') {
5039             $here_script = CORE::substr $_, pos $_;
5040 0 0       0 $here_script =~ s/.*?\n//oxm;
5041 0         0 }
5042 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5043             push @heredoc, $1 . qq{\n$delimiter\n};
5044             push @heredoc_delimiter, $delimiter;
5045 0         0 }
5046             else {
5047 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5048             }
5049             $e_string .= $here_quote;
5050             }
5051              
5052 0         0 # <<\HEREDOC
5053 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5054 0         0 $slash = 'm//';
5055             my $here_quote = $1;
5056             my $delimiter = $2;
5057 0 0       0  
5058 0         0 # get here document
5059 0         0 if ($here_script eq '') {
5060             $here_script = CORE::substr $_, pos $_;
5061 0 0       0 $here_script =~ s/.*?\n//oxm;
5062 0         0 }
5063 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5064             push @heredoc, $1 . qq{\n$delimiter\n};
5065             push @heredoc_delimiter, $delimiter;
5066 0         0 }
5067             else {
5068 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5069             }
5070             $e_string .= $here_quote;
5071             }
5072              
5073 0         0 # <<"HEREDOC"
5074 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5075 0         0 $slash = 'm//';
5076             my $here_quote = $1;
5077             my $delimiter = $2;
5078 0 0       0  
5079 0         0 # get here document
5080 0         0 if ($here_script eq '') {
5081             $here_script = CORE::substr $_, pos $_;
5082 0 0       0 $here_script =~ s/.*?\n//oxm;
5083 0         0 }
5084 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5085             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5086             push @heredoc_delimiter, $delimiter;
5087 0         0 }
5088             else {
5089 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5090             }
5091             $e_string .= $here_quote;
5092             }
5093              
5094 0         0 # <
5095 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5096 0         0 $slash = 'm//';
5097             my $here_quote = $1;
5098             my $delimiter = $2;
5099 0 0       0  
5100 0         0 # get here document
5101 0         0 if ($here_script eq '') {
5102             $here_script = CORE::substr $_, pos $_;
5103 0 0       0 $here_script =~ s/.*?\n//oxm;
5104 0         0 }
5105 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5106             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5107             push @heredoc_delimiter, $delimiter;
5108 0         0 }
5109             else {
5110 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5111             }
5112             $e_string .= $here_quote;
5113             }
5114              
5115 0         0 # <<`HEREDOC`
5116 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5117 0         0 $slash = 'm//';
5118             my $here_quote = $1;
5119             my $delimiter = $2;
5120 0 0       0  
5121 0         0 # get here document
5122 0         0 if ($here_script eq '') {
5123             $here_script = CORE::substr $_, pos $_;
5124 0 0       0 $here_script =~ s/.*?\n//oxm;
5125 0         0 }
5126 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5127             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5128             push @heredoc_delimiter, $delimiter;
5129 0         0 }
5130             else {
5131 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5132             }
5133             $e_string .= $here_quote;
5134             }
5135              
5136             # any operator before div
5137             elsif ($string =~ /\G (
5138             -- | \+\+ |
5139 0         0 [\)\}\]]
  18         34  
5140              
5141             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5142              
5143             # yada-yada or triple-dot operator
5144             elsif ($string =~ /\G (
5145 18         52 \.\.\.
  0         0  
5146              
5147             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5148              
5149             # any operator before m//
5150             elsif ($string =~ /\G ((?>
5151              
5152             !~~ | !~ | != | ! |
5153             %= | % |
5154             &&= | && | &= | &\.= | &\. | & |
5155             -= | -> | - |
5156             :(?>\s*)= |
5157             : |
5158             <<>> |
5159             <<= | <=> | <= | < |
5160             == | => | =~ | = |
5161             >>= | >> | >= | > |
5162             \*\*= | \*\* | \*= | \* |
5163             \+= | \+ |
5164             \.\. | \.= | \. |
5165             \/\/= | \/\/ |
5166             \/= | \/ |
5167             \? |
5168             \\ |
5169             \^= | \^\.= | \^\. | \^ |
5170             \b x= |
5171             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5172             ~~ | ~\. | ~ |
5173             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5174             \b(?: print )\b |
5175              
5176 0         0 [,;\(\{\[]
  31         58  
5177              
5178             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5179 31         106  
5180             # other any character
5181             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5182              
5183 131         345 # system error
5184             else {
5185             die __FILE__, ": Oops, this shouldn't happen!\n";
5186             }
5187 0         0 }
5188              
5189             return $e_string;
5190             }
5191              
5192             #
5193             # character class
5194 17     1919 0 73 #
5195             sub character_class {
5196 1919 100       3789 my($char,$modifier) = @_;
5197 1919 100       3140  
5198 52         115 if ($char eq '.') {
5199             if ($modifier =~ /s/) {
5200             return '${Elatin6::dot_s}';
5201 17         40 }
5202             else {
5203             return '${Elatin6::dot}';
5204             }
5205 35         156 }
5206             else {
5207             return Elatin6::classic_character_class($char);
5208             }
5209             }
5210              
5211             #
5212             # escape capture ($1, $2, $3, ...)
5213             #
5214 1867     212 0 3445 sub e_capture {
5215              
5216             return join '', '${', $_[0], '}';
5217             }
5218              
5219             #
5220             # escape transliteration (tr/// or y///)
5221 212     3 0 1347 #
5222 3         17 sub e_tr {
5223 3   50     6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5224             my $e_tr = '';
5225 3         7 $modifier ||= '';
5226              
5227             $slash = 'div';
5228 3         4  
5229             # quote character class 1
5230             $charclass = q_tr($charclass);
5231 3         5  
5232             # quote character class 2
5233             $charclass2 = q_tr($charclass2);
5234 3 50       5  
5235 3 0       9 # /b /B modifier
5236 0         0 if ($modifier =~ tr/bB//d) {
5237             if ($variable eq '') {
5238             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5239 0         0 }
5240             else {
5241             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5242             }
5243 0 100       0 }
5244 3         7 else {
5245             if ($variable eq '') {
5246             $e_tr = qq{Elatin6::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5247 2         7 }
5248             else {
5249             $e_tr = qq{Elatin6::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5250             }
5251             }
5252 1         5  
5253 3         4 # clear tr/// variable
5254             $tr_variable = '';
5255 3         4 $bind_operator = '';
5256              
5257             return $e_tr;
5258             }
5259              
5260             #
5261             # quote for escape transliteration (tr/// or y///)
5262 3     6 0 15 #
5263             sub q_tr {
5264             my($charclass) = @_;
5265 6 50       12  
    0          
    0          
    0          
    0          
    0          
5266 6         10 # quote character class
5267             if ($charclass !~ /'/oxms) {
5268             return e_q('', "'", "'", $charclass); # --> q' '
5269 6         9 }
5270             elsif ($charclass !~ /\//oxms) {
5271             return e_q('q', '/', '/', $charclass); # --> q/ /
5272 0         0 }
5273             elsif ($charclass !~ /\#/oxms) {
5274             return e_q('q', '#', '#', $charclass); # --> q# #
5275 0         0 }
5276             elsif ($charclass !~ /[\<\>]/oxms) {
5277             return e_q('q', '<', '>', $charclass); # --> q< >
5278 0         0 }
5279             elsif ($charclass !~ /[\(\)]/oxms) {
5280             return e_q('q', '(', ')', $charclass); # --> q( )
5281 0         0 }
5282             elsif ($charclass !~ /[\{\}]/oxms) {
5283             return e_q('q', '{', '}', $charclass); # --> q{ }
5284 0         0 }
5285 0 0       0 else {
5286 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5287             if ($charclass !~ /\Q$char\E/xms) {
5288             return e_q('q', $char, $char, $charclass);
5289             }
5290             }
5291 0         0 }
5292              
5293             return e_q('q', '{', '}', $charclass);
5294             }
5295              
5296             #
5297             # escape q string (q//, '')
5298 0     1264 0 0 #
5299             sub e_q {
5300 1264         2882 my($ope,$delimiter,$end_delimiter,$string) = @_;
5301              
5302 1264         1671 $slash = 'div';
5303              
5304             return join '', $ope, $delimiter, $string, $end_delimiter;
5305             }
5306              
5307             #
5308             # escape qq string (qq//, "", qx//, ``)
5309 1264     4110 0 6008 #
5310             sub e_qq {
5311 4110         9411 my($ope,$delimiter,$end_delimiter,$string) = @_;
5312              
5313 4110         5398 $slash = 'div';
5314 4110         5328  
5315             my $left_e = 0;
5316             my $right_e = 0;
5317 4110         4818  
5318             # split regexp
5319             my @char = $string =~ /\G((?>
5320             [^\\\$] |
5321             \\x\{ (?>[0-9A-Fa-f]+) \} |
5322             \\o\{ (?>[0-7]+) \} |
5323             \\N\{ (?>[^0-9\}][^\}]*) \} |
5324             \\ $q_char |
5325             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5326             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5327             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5328             \$ (?>\s* [0-9]+) |
5329             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5330             \$ \$ (?![\w\{]) |
5331             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5332             $q_char
5333 4110         142225 ))/oxmsg;
5334              
5335             for (my $i=0; $i <= $#char; $i++) {
5336 4110 50 33     13150  
    50 33        
    100          
    100          
    50          
5337 113973         375608 # "\L\u" --> "\u\L"
5338             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5339             @char[$i,$i+1] = @char[$i+1,$i];
5340             }
5341              
5342 0         0 # "\U\l" --> "\l\U"
5343             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5344             @char[$i,$i+1] = @char[$i+1,$i];
5345             }
5346              
5347 0         0 # octal escape sequence
5348             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5349             $char[$i] = Elatin6::octchr($1);
5350             }
5351              
5352 1         55 # hexadecimal escape sequence
5353             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5354             $char[$i] = Elatin6::hexchr($1);
5355             }
5356              
5357 1         3 # \N{CHARNAME} --> N{CHARNAME}
5358             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5359             $char[$i] = $1;
5360 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          
5361              
5362             if (0) {
5363             }
5364              
5365             # \F
5366             #
5367             # P.69 Table 2-6. Translation escapes
5368             # in Chapter 2: Bits and Pieces
5369             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5370             # (and so on)
5371 113973         903322  
5372 0 50       0 # \u \l \U \L \F \Q \E
5373 484         1081 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5374             if ($right_e < $left_e) {
5375             $char[$i] = '\\' . $char[$i];
5376             }
5377             }
5378             elsif ($char[$i] eq '\u') {
5379              
5380             # "STRING @{[ LIST EXPR ]} MORE STRING"
5381              
5382             # P.257 Other Tricks You Can Do with Hard References
5383             # in Chapter 8: References
5384             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5385              
5386             # P.353 Other Tricks You Can Do with Hard References
5387             # in Chapter 8: References
5388             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5389              
5390 0         0 # (and so on)
5391 0         0  
5392             $char[$i] = '@{[Elatin6::ucfirst qq<';
5393             $left_e++;
5394 0         0 }
5395 0         0 elsif ($char[$i] eq '\l') {
5396             $char[$i] = '@{[Elatin6::lcfirst qq<';
5397             $left_e++;
5398 0         0 }
5399 0         0 elsif ($char[$i] eq '\U') {
5400             $char[$i] = '@{[Elatin6::uc qq<';
5401             $left_e++;
5402 0         0 }
5403 0         0 elsif ($char[$i] eq '\L') {
5404             $char[$i] = '@{[Elatin6::lc qq<';
5405             $left_e++;
5406 0         0 }
5407 24         31 elsif ($char[$i] eq '\F') {
5408             $char[$i] = '@{[Elatin6::fc qq<';
5409             $left_e++;
5410 24         45 }
5411 0         0 elsif ($char[$i] eq '\Q') {
5412             $char[$i] = '@{[CORE::quotemeta qq<';
5413             $left_e++;
5414 0 50       0 }
5415 24         35 elsif ($char[$i] eq '\E') {
5416 24         33 if ($right_e < $left_e) {
5417             $char[$i] = '>]}';
5418             $right_e++;
5419 24         41 }
5420             else {
5421             $char[$i] = '';
5422             }
5423 0         0 }
5424 0 0       0 elsif ($char[$i] eq '\Q') {
5425 0         0 while (1) {
5426             if (++$i > $#char) {
5427 0 0       0 last;
5428 0         0 }
5429             if ($char[$i] eq '\E') {
5430             last;
5431             }
5432             }
5433             }
5434             elsif ($char[$i] eq '\E') {
5435             }
5436              
5437             # $0 --> $0
5438             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5439             }
5440             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5441             }
5442              
5443             # $$ --> $$
5444             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5445             }
5446              
5447             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5448 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5449             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5450             $char[$i] = e_capture($1);
5451 205         566 }
5452             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5453             $char[$i] = e_capture($1);
5454             }
5455              
5456 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5457             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5458             $char[$i] = e_capture($1.'->'.$2);
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_brace)*? \} ) \z/oxms) {
5463             $char[$i] = e_capture($1.'->'.$2);
5464             }
5465              
5466 0         0 # $$foo
5467             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5468             $char[$i] = e_capture($1);
5469             }
5470              
5471 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
5472             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5473             $char[$i] = '@{[Elatin6::PREMATCH()]}';
5474             }
5475              
5476 44         118 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
5477             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5478             $char[$i] = '@{[Elatin6::MATCH()]}';
5479             }
5480              
5481 45         131 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
5482             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5483             $char[$i] = '@{[Elatin6::POSTMATCH()]}';
5484             }
5485              
5486             # ${ foo } --> ${ foo }
5487             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5488             }
5489              
5490 33         91 # ${ ... }
5491             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5492             $char[$i] = e_capture($1);
5493             }
5494             }
5495 0 50       0  
5496 4110         45231 # return string
5497             if ($left_e > $right_e) {
5498 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5499             }
5500             return join '', $ope, $delimiter, @char, $end_delimiter;
5501             }
5502              
5503             #
5504             # escape qw string (qw//)
5505 4110     16 0 35153 #
5506             sub e_qw {
5507 16         92 my($ope,$delimiter,$end_delimiter,$string) = @_;
5508              
5509             $slash = 'div';
5510 16         37  
  16         221  
5511 483 50       721 # choice again delimiter
    0          
    0          
    0          
    0          
5512 16         105 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5513             if (not $octet{$end_delimiter}) {
5514             return join '', $ope, $delimiter, $string, $end_delimiter;
5515 16         133 }
5516             elsif (not $octet{')'}) {
5517             return join '', $ope, '(', $string, ')';
5518 0         0 }
5519             elsif (not $octet{'}'}) {
5520             return join '', $ope, '{', $string, '}';
5521 0         0 }
5522             elsif (not $octet{']'}) {
5523             return join '', $ope, '[', $string, ']';
5524 0         0 }
5525             elsif (not $octet{'>'}) {
5526             return join '', $ope, '<', $string, '>';
5527 0         0 }
5528 0 0       0 else {
5529 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5530             if (not $octet{$char}) {
5531             return join '', $ope, $char, $string, $char;
5532             }
5533             }
5534             }
5535 0         0  
5536 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5537 0         0 my @string = CORE::split(/\s+/, $string);
5538 0         0 for my $string (@string) {
5539 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5540 0         0 for my $octet (@octet) {
5541             if ($octet =~ /\A (['\\]) \z/oxms) {
5542             $octet = '\\' . $1;
5543 0         0 }
5544             }
5545 0         0 $string = join '', @octet;
  0         0  
5546             }
5547             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5548             }
5549              
5550             #
5551             # escape here document (<<"HEREDOC", <
5552 0     93 0 0 #
5553             sub e_heredoc {
5554 93         276 my($string) = @_;
5555              
5556 93         158 $slash = 'm//';
5557              
5558 93         300 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5559 93         147  
5560             my $left_e = 0;
5561             my $right_e = 0;
5562 93         127  
5563             # split regexp
5564             my @char = $string =~ /\G((?>
5565             [^\\\$] |
5566             \\x\{ (?>[0-9A-Fa-f]+) \} |
5567             \\o\{ (?>[0-7]+) \} |
5568             \\N\{ (?>[^0-9\}][^\}]*) \} |
5569             \\ $q_char |
5570             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5571             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5572             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5573             \$ (?>\s* [0-9]+) |
5574             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5575             \$ \$ (?![\w\{]) |
5576             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5577             $q_char
5578 93         33128 ))/oxmsg;
5579              
5580             for (my $i=0; $i <= $#char; $i++) {
5581 93 50 33     477  
    50 33        
    100          
    100          
    50          
5582 3177         10281 # "\L\u" --> "\u\L"
5583             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5584             @char[$i,$i+1] = @char[$i+1,$i];
5585             }
5586              
5587 0         0 # "\U\l" --> "\l\U"
5588             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5589             @char[$i,$i+1] = @char[$i+1,$i];
5590             }
5591              
5592 0         0 # octal escape sequence
5593             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5594             $char[$i] = Elatin6::octchr($1);
5595             }
5596              
5597 1         3 # hexadecimal escape sequence
5598             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5599             $char[$i] = Elatin6::hexchr($1);
5600             }
5601              
5602 1         4 # \N{CHARNAME} --> N{CHARNAME}
5603             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5604             $char[$i] = $1;
5605 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          
5606              
5607             if (0) {
5608             }
5609 3177         26634  
5610 0 0       0 # \u \l \U \L \F \Q \E
5611 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5612             if ($right_e < $left_e) {
5613             $char[$i] = '\\' . $char[$i];
5614             }
5615 0         0 }
5616 0         0 elsif ($char[$i] eq '\u') {
5617             $char[$i] = '@{[Elatin6::ucfirst qq<';
5618             $left_e++;
5619 0         0 }
5620 0         0 elsif ($char[$i] eq '\l') {
5621             $char[$i] = '@{[Elatin6::lcfirst qq<';
5622             $left_e++;
5623 0         0 }
5624 0         0 elsif ($char[$i] eq '\U') {
5625             $char[$i] = '@{[Elatin6::uc qq<';
5626             $left_e++;
5627 0         0 }
5628 0         0 elsif ($char[$i] eq '\L') {
5629             $char[$i] = '@{[Elatin6::lc qq<';
5630             $left_e++;
5631 0         0 }
5632 0         0 elsif ($char[$i] eq '\F') {
5633             $char[$i] = '@{[Elatin6::fc qq<';
5634             $left_e++;
5635 0         0 }
5636 0         0 elsif ($char[$i] eq '\Q') {
5637             $char[$i] = '@{[CORE::quotemeta qq<';
5638             $left_e++;
5639 0 0       0 }
5640 0         0 elsif ($char[$i] eq '\E') {
5641 0         0 if ($right_e < $left_e) {
5642             $char[$i] = '>]}';
5643             $right_e++;
5644 0         0 }
5645             else {
5646             $char[$i] = '';
5647             }
5648 0         0 }
5649 0 0       0 elsif ($char[$i] eq '\Q') {
5650 0         0 while (1) {
5651             if (++$i > $#char) {
5652 0 0       0 last;
5653 0         0 }
5654             if ($char[$i] eq '\E') {
5655             last;
5656             }
5657             }
5658             }
5659             elsif ($char[$i] eq '\E') {
5660             }
5661              
5662             # $0 --> $0
5663             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5664             }
5665             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5666             }
5667              
5668             # $$ --> $$
5669             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5670             }
5671              
5672             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5673 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5674             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5675             $char[$i] = e_capture($1);
5676 0         0 }
5677             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5678             $char[$i] = e_capture($1);
5679             }
5680              
5681 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5682             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5683             $char[$i] = e_capture($1.'->'.$2);
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_brace)*? \} ) \z/oxms) {
5688             $char[$i] = e_capture($1.'->'.$2);
5689             }
5690              
5691 0         0 # $$foo
5692             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5693             $char[$i] = e_capture($1);
5694             }
5695              
5696 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
5697             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5698             $char[$i] = '@{[Elatin6::PREMATCH()]}';
5699             }
5700              
5701 8         51 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
5702             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5703             $char[$i] = '@{[Elatin6::MATCH()]}';
5704             }
5705              
5706 8         44 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
5707             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5708             $char[$i] = '@{[Elatin6::POSTMATCH()]}';
5709             }
5710              
5711             # ${ foo } --> ${ foo }
5712             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5713             }
5714              
5715 6         33 # ${ ... }
5716             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5717             $char[$i] = e_capture($1);
5718             }
5719             }
5720 0 50       0  
5721 93         209 # return string
5722             if ($left_e > $right_e) {
5723 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5724             }
5725             return join '', @char;
5726             }
5727              
5728             #
5729             # escape regexp (m//, qr//)
5730 93     652 0 722 #
5731 652   100     3019 sub e_qr {
5732             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5733 652         3141 $modifier ||= '';
5734 652 50       1113  
5735 652         2066 $modifier =~ tr/p//d;
5736 0         0 if ($modifier =~ /([adlu])/oxms) {
5737 0 0       0 my $line = 0;
5738 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5739 0         0 if ($filename ne __FILE__) {
5740             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5741             last;
5742 0         0 }
5743             }
5744             die qq{Unsupported modifier "$1" used at line $line.\n};
5745 0         0 }
5746              
5747             $slash = 'div';
5748 652 100       1011  
    100          
5749 652         2079 # literal null string pattern
5750 8         10 if ($string eq '') {
5751 8         11 $modifier =~ tr/bB//d;
5752             $modifier =~ tr/i//d;
5753             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5754             }
5755              
5756             # /b /B modifier
5757             elsif ($modifier =~ tr/bB//d) {
5758 8 50       38  
5759 2         6 # choice again delimiter
5760 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5761 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5762 0         0 my %octet = map {$_ => 1} @char;
5763 0         0 if (not $octet{')'}) {
5764             $delimiter = '(';
5765             $end_delimiter = ')';
5766 0         0 }
5767 0         0 elsif (not $octet{'}'}) {
5768             $delimiter = '{';
5769             $end_delimiter = '}';
5770 0         0 }
5771 0         0 elsif (not $octet{']'}) {
5772             $delimiter = '[';
5773             $end_delimiter = ']';
5774 0         0 }
5775 0         0 elsif (not $octet{'>'}) {
5776             $delimiter = '<';
5777             $end_delimiter = '>';
5778 0         0 }
5779 0 0       0 else {
5780 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5781 0         0 if (not $octet{$char}) {
5782 0         0 $delimiter = $char;
5783             $end_delimiter = $char;
5784             last;
5785             }
5786             }
5787             }
5788 0 50 33     0 }
5789 2         16  
5790             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5791             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5792 0         0 }
5793             else {
5794             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5795             }
5796 2 100       12 }
5797 642         1655  
5798             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5799             my $metachar = qr/[\@\\|[\]{^]/oxms;
5800 642         2414  
5801             # split regexp
5802             my @char = $string =~ /\G((?>
5803             [^\\\$\@\[\(] |
5804             \\x (?>[0-9A-Fa-f]{1,2}) |
5805             \\ (?>[0-7]{2,3}) |
5806             \\c [\x40-\x5F] |
5807             \\x\{ (?>[0-9A-Fa-f]+) \} |
5808             \\o\{ (?>[0-7]+) \} |
5809             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5810             \\ $q_char |
5811             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5812             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5813             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5814             [\$\@] $qq_variable |
5815             \$ (?>\s* [0-9]+) |
5816             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5817             \$ \$ (?![\w\{]) |
5818             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5819             \[\^ |
5820             \[\: (?>[a-z]+) :\] |
5821             \[\:\^ (?>[a-z]+) :\] |
5822             \(\? |
5823             $q_char
5824             ))/oxmsg;
5825 642 50       70990  
5826 642         4010 # choice again delimiter
  0         0  
5827 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5828 0         0 my %octet = map {$_ => 1} @char;
5829 0         0 if (not $octet{')'}) {
5830             $delimiter = '(';
5831             $end_delimiter = ')';
5832 0         0 }
5833 0         0 elsif (not $octet{'}'}) {
5834             $delimiter = '{';
5835             $end_delimiter = '}';
5836 0         0 }
5837 0         0 elsif (not $octet{']'}) {
5838             $delimiter = '[';
5839             $end_delimiter = ']';
5840 0         0 }
5841 0         0 elsif (not $octet{'>'}) {
5842             $delimiter = '<';
5843             $end_delimiter = '>';
5844 0         0 }
5845 0 0       0 else {
5846 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5847 0         0 if (not $octet{$char}) {
5848 0         0 $delimiter = $char;
5849             $end_delimiter = $char;
5850             last;
5851             }
5852             }
5853             }
5854 0         0 }
5855 642         1049  
5856 642         879 my $left_e = 0;
5857             my $right_e = 0;
5858             for (my $i=0; $i <= $#char; $i++) {
5859 642 50 66     1590  
    50 66        
    100          
    100          
    100          
    100          
5860 1872         10612 # "\L\u" --> "\u\L"
5861             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5862             @char[$i,$i+1] = @char[$i+1,$i];
5863             }
5864              
5865 0         0 # "\U\l" --> "\l\U"
5866             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5867             @char[$i,$i+1] = @char[$i+1,$i];
5868             }
5869              
5870 0         0 # octal escape sequence
5871             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5872             $char[$i] = Elatin6::octchr($1);
5873             }
5874              
5875 1         3 # hexadecimal escape sequence
5876             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5877             $char[$i] = Elatin6::hexchr($1);
5878             }
5879              
5880             # \b{...} --> b\{...}
5881             # \B{...} --> B\{...}
5882             # \N{CHARNAME} --> N\{CHARNAME}
5883             # \p{PROPERTY} --> p\{PROPERTY}
5884 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5885             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5886             $char[$i] = $1 . '\\' . $2;
5887             }
5888              
5889 6         19 # \p, \P, \X --> p, P, X
5890             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5891             $char[$i] = $1;
5892 4 100 100     11 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5893              
5894             if (0) {
5895             }
5896 1872         6897  
5897 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5898 6         85 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5899             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)) {
5900             $char[$i] .= join '', splice @char, $i+1, 3;
5901 0         0 }
5902             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)) {
5903             $char[$i] .= join '', splice @char, $i+1, 2;
5904 0         0 }
5905             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)) {
5906             $char[$i] .= join '', splice @char, $i+1, 1;
5907             }
5908             }
5909              
5910 0         0 # open character class [...]
5911             elsif ($char[$i] eq '[') {
5912             my $left = $i;
5913              
5914             # [] make die "Unmatched [] in regexp ...\n"
5915 328 100       429 # (and so on)
5916 328         765  
5917             if ($char[$i+1] eq ']') {
5918             $i++;
5919 3         6 }
5920 328 50       389  
5921 1379         2135 while (1) {
5922             if (++$i > $#char) {
5923 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5924 1379         2208 }
5925             if ($char[$i] eq ']') {
5926             my $right = $i;
5927 328 100       399  
5928 328         2013 # [...]
  30         130  
5929             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5930             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);
5931 90         267 }
5932             else {
5933             splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
5934 298         1144 }
5935 328         571  
5936             $i = $left;
5937             last;
5938             }
5939             }
5940             }
5941              
5942 328         802 # open character class [^...]
5943             elsif ($char[$i] eq '[^') {
5944             my $left = $i;
5945              
5946             # [^] make die "Unmatched [] in regexp ...\n"
5947 74 100       102 # (and so on)
5948 74         174  
5949             if ($char[$i+1] eq ']') {
5950             $i++;
5951 4         5 }
5952 74 50       94  
5953 272         454 while (1) {
5954             if (++$i > $#char) {
5955 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5956 272         436 }
5957             if ($char[$i] eq ']') {
5958             my $right = $i;
5959 74 100       98  
5960 74         390 # [^...]
  30         71  
5961             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5962             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);
5963 90         143 }
5964             else {
5965             splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5966 44         191 }
5967 74         141  
5968             $i = $left;
5969             last;
5970             }
5971             }
5972             }
5973              
5974 74         188 # rewrite character class or escape character
5975             elsif (my $char = character_class($char[$i],$modifier)) {
5976             $char[$i] = $char;
5977             }
5978              
5979 139 50       364 # /i modifier
5980 20         30 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
5981             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
5982             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
5983 20         29 }
5984             else {
5985             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
5986             }
5987             }
5988              
5989 0 50       0 # \u \l \U \L \F \Q \E
5990 1         4 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5991             if ($right_e < $left_e) {
5992             $char[$i] = '\\' . $char[$i];
5993             }
5994 0         0 }
5995 0         0 elsif ($char[$i] eq '\u') {
5996             $char[$i] = '@{[Elatin6::ucfirst qq<';
5997             $left_e++;
5998 0         0 }
5999 0         0 elsif ($char[$i] eq '\l') {
6000             $char[$i] = '@{[Elatin6::lcfirst qq<';
6001             $left_e++;
6002 0         0 }
6003 1         3 elsif ($char[$i] eq '\U') {
6004             $char[$i] = '@{[Elatin6::uc qq<';
6005             $left_e++;
6006 1         4 }
6007 1         3 elsif ($char[$i] eq '\L') {
6008             $char[$i] = '@{[Elatin6::lc qq<';
6009             $left_e++;
6010 1         4 }
6011 18         32 elsif ($char[$i] eq '\F') {
6012             $char[$i] = '@{[Elatin6::fc qq<';
6013             $left_e++;
6014 18         37 }
6015 1         3 elsif ($char[$i] eq '\Q') {
6016             $char[$i] = '@{[CORE::quotemeta qq<';
6017             $left_e++;
6018 1 50       3 }
6019 21         41 elsif ($char[$i] eq '\E') {
6020 21         26 if ($right_e < $left_e) {
6021             $char[$i] = '>]}';
6022             $right_e++;
6023 21         72 }
6024             else {
6025             $char[$i] = '';
6026             }
6027 0         0 }
6028 0 0       0 elsif ($char[$i] eq '\Q') {
6029 0         0 while (1) {
6030             if (++$i > $#char) {
6031 0 0       0 last;
6032 0         0 }
6033             if ($char[$i] eq '\E') {
6034             last;
6035             }
6036             }
6037             }
6038             elsif ($char[$i] eq '\E') {
6039             }
6040              
6041 0 0       0 # $0 --> $0
6042 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6043             if ($ignorecase) {
6044             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6045             }
6046 0 0       0 }
6047 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6048             if ($ignorecase) {
6049             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6050             }
6051             }
6052              
6053             # $$ --> $$
6054             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6055             }
6056              
6057             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6058 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6059 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6060 0         0 $char[$i] = e_capture($1);
6061             if ($ignorecase) {
6062             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6063             }
6064 0         0 }
6065 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6066 0         0 $char[$i] = e_capture($1);
6067             if ($ignorecase) {
6068             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6069             }
6070             }
6071              
6072 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6073 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) {
6074 0         0 $char[$i] = e_capture($1.'->'.$2);
6075             if ($ignorecase) {
6076             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6077             }
6078             }
6079              
6080 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6081 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) {
6082 0         0 $char[$i] = e_capture($1.'->'.$2);
6083             if ($ignorecase) {
6084             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6085             }
6086             }
6087              
6088 0         0 # $$foo
6089 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6090 0         0 $char[$i] = e_capture($1);
6091             if ($ignorecase) {
6092             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6093             }
6094             }
6095              
6096 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
6097 8         22 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6098             if ($ignorecase) {
6099             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
6100 0         0 }
6101             else {
6102             $char[$i] = '@{[Elatin6::PREMATCH()]}';
6103             }
6104             }
6105              
6106 8 50       21 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
6107 8         25 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6108             if ($ignorecase) {
6109             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
6110 0         0 }
6111             else {
6112             $char[$i] = '@{[Elatin6::MATCH()]}';
6113             }
6114             }
6115              
6116 8 50       24 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
6117 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6118             if ($ignorecase) {
6119             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
6120 0         0 }
6121             else {
6122             $char[$i] = '@{[Elatin6::POSTMATCH()]}';
6123             }
6124             }
6125              
6126 6 0       18 # ${ foo }
6127 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) {
6128             if ($ignorecase) {
6129             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6130             }
6131             }
6132              
6133 0         0 # ${ ... }
6134 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6135 0         0 $char[$i] = e_capture($1);
6136             if ($ignorecase) {
6137             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6138             }
6139             }
6140              
6141 0         0 # $scalar or @array
6142 21 100       50 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6143 21         112 $char[$i] = e_string($char[$i]);
6144             if ($ignorecase) {
6145             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6146             }
6147             }
6148              
6149 11 100 33     32 # quote character before ? + * {
    50          
6150             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6151             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6152 138         993 }
6153 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6154 0         0 my $char = $char[$i-1];
6155             if ($char[$i] eq '{') {
6156             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6157 0         0 }
6158             else {
6159             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6160             }
6161 0         0 }
6162             else {
6163             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6164             }
6165             }
6166             }
6167 127         471  
6168 642 50       1247 # make regexp string
6169 642 0 0     1291 $modifier =~ tr/i//d;
6170 0         0 if ($left_e > $right_e) {
6171             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6172             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6173 0         0 }
6174             else {
6175             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6176 0 50 33     0 }
6177 642         3510 }
6178             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6179             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6180 0         0 }
6181             else {
6182             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6183             }
6184             }
6185              
6186             #
6187             # double quote stuff
6188 642     180 0 5552 #
6189             sub qq_stuff {
6190             my($delimiter,$end_delimiter,$stuff) = @_;
6191 180 100       281  
6192 180         390 # scalar variable or array variable
6193             if ($stuff =~ /\A [\$\@] /oxms) {
6194             return $stuff;
6195             }
6196 100         397  
  80         186  
6197 80         225 # quote by delimiter
6198 80 50       191 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6199 80 50       138 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6200 80 50       128 next if $char eq $delimiter;
6201 80         137 next if $char eq $end_delimiter;
6202             if (not $octet{$char}) {
6203             return join '', 'qq', $char, $stuff, $char;
6204 80         313 }
6205             }
6206             return join '', 'qq', '<', $stuff, '>';
6207             }
6208              
6209             #
6210             # escape regexp (m'', qr'', and m''b, qr''b)
6211 0     10 0 0 #
6212 10   50     39 sub e_qr_q {
6213             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6214 10         36 $modifier ||= '';
6215 10 50       16  
6216 10         17 $modifier =~ tr/p//d;
6217 0         0 if ($modifier =~ /([adlu])/oxms) {
6218 0 0       0 my $line = 0;
6219 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6220 0         0 if ($filename ne __FILE__) {
6221             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6222             last;
6223 0         0 }
6224             }
6225             die qq{Unsupported modifier "$1" used at line $line.\n};
6226 0         0 }
6227              
6228             $slash = 'div';
6229 10 100       14  
    50          
6230 10         19 # literal null string pattern
6231 8         8 if ($string eq '') {
6232 8         10 $modifier =~ tr/bB//d;
6233             $modifier =~ tr/i//d;
6234             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6235             }
6236              
6237 8         35 # with /b /B modifier
6238             elsif ($modifier =~ tr/bB//d) {
6239             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6240             }
6241              
6242 0         0 # without /b /B modifier
6243             else {
6244             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6245             }
6246             }
6247              
6248             #
6249             # escape regexp (m'', qr'')
6250 2     2 0 6 #
6251             sub e_qr_qt {
6252 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6253              
6254             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6255 2         5  
6256             # split regexp
6257             my @char = $string =~ /\G((?>
6258             [^\\\[\$\@\/] |
6259             [\x00-\xFF] |
6260             \[\^ |
6261             \[\: (?>[a-z]+) \:\] |
6262             \[\:\^ (?>[a-z]+) \:\] |
6263             [\$\@\/] |
6264             \\ (?:$q_char) |
6265             (?:$q_char)
6266             ))/oxmsg;
6267 2         57  
6268 2 50 33     9 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6269             for (my $i=0; $i <= $#char; $i++) {
6270             if (0) {
6271             }
6272 2         14  
6273 0         0 # open character class [...]
6274 0 0       0 elsif ($char[$i] eq '[') {
6275 0         0 my $left = $i;
6276             if ($char[$i+1] eq ']') {
6277 0         0 $i++;
6278 0 0       0 }
6279 0         0 while (1) {
6280             if (++$i > $#char) {
6281 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6282 0         0 }
6283             if ($char[$i] eq ']') {
6284             my $right = $i;
6285 0         0  
6286             # [...]
6287 0         0 splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
6288 0         0  
6289             $i = $left;
6290             last;
6291             }
6292             }
6293             }
6294              
6295 0         0 # open character class [^...]
6296 0 0       0 elsif ($char[$i] eq '[^') {
6297 0         0 my $left = $i;
6298             if ($char[$i+1] eq ']') {
6299 0         0 $i++;
6300 0 0       0 }
6301 0         0 while (1) {
6302             if (++$i > $#char) {
6303 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6304 0         0 }
6305             if ($char[$i] eq ']') {
6306             my $right = $i;
6307 0         0  
6308             # [^...]
6309 0         0 splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6310 0         0  
6311             $i = $left;
6312             last;
6313             }
6314             }
6315             }
6316              
6317 0         0 # escape $ @ / and \
6318             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6319             $char[$i] = '\\' . $char[$i];
6320             }
6321              
6322 0         0 # rewrite character class or escape character
6323             elsif (my $char = character_class($char[$i],$modifier)) {
6324             $char[$i] = $char;
6325             }
6326              
6327 0 0       0 # /i modifier
6328 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6329             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6330             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6331 0         0 }
6332             else {
6333             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
6334             }
6335             }
6336              
6337 0 0       0 # quote character before ? + * {
6338             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6339             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6340 0         0 }
6341             else {
6342             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6343             }
6344             }
6345 0         0 }
6346 2         3  
6347             $delimiter = '/';
6348 2         3 $end_delimiter = '/';
6349 2         3  
6350             $modifier =~ tr/i//d;
6351             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6352             }
6353              
6354             #
6355             # escape regexp (m''b, qr''b)
6356 2     0 0 12 #
6357             sub e_qr_qb {
6358             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6359 0         0  
6360             # split regexp
6361             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6362 0         0  
6363 0 0       0 # unescape character
    0          
6364             for (my $i=0; $i <= $#char; $i++) {
6365             if (0) {
6366             }
6367 0         0  
6368             # remain \\
6369             elsif ($char[$i] eq '\\\\') {
6370             }
6371              
6372 0         0 # escape $ @ / and \
6373             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6374             $char[$i] = '\\' . $char[$i];
6375             }
6376 0         0 }
6377 0         0  
6378 0         0 $delimiter = '/';
6379             $end_delimiter = '/';
6380             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6381             }
6382              
6383             #
6384             # escape regexp (s/here//)
6385 0     76 0 0 #
6386 76   100     216 sub e_s1 {
6387             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6388 76         314 $modifier ||= '';
6389 76 50       116  
6390 76         201 $modifier =~ tr/p//d;
6391 0         0 if ($modifier =~ /([adlu])/oxms) {
6392 0 0       0 my $line = 0;
6393 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6394 0         0 if ($filename ne __FILE__) {
6395             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6396             last;
6397 0         0 }
6398             }
6399             die qq{Unsupported modifier "$1" used at line $line.\n};
6400 0         0 }
6401              
6402             $slash = 'div';
6403 76 100       125  
    50          
6404 76         229 # literal null string pattern
6405 8         9 if ($string eq '') {
6406 8         8 $modifier =~ tr/bB//d;
6407             $modifier =~ tr/i//d;
6408             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6409             }
6410              
6411             # /b /B modifier
6412             elsif ($modifier =~ tr/bB//d) {
6413 8 0       47  
6414 0         0 # choice again delimiter
6415 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6416 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6417 0         0 my %octet = map {$_ => 1} @char;
6418 0         0 if (not $octet{')'}) {
6419             $delimiter = '(';
6420             $end_delimiter = ')';
6421 0         0 }
6422 0         0 elsif (not $octet{'}'}) {
6423             $delimiter = '{';
6424             $end_delimiter = '}';
6425 0         0 }
6426 0         0 elsif (not $octet{']'}) {
6427             $delimiter = '[';
6428             $end_delimiter = ']';
6429 0         0 }
6430 0         0 elsif (not $octet{'>'}) {
6431             $delimiter = '<';
6432             $end_delimiter = '>';
6433 0         0 }
6434 0 0       0 else {
6435 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6436 0         0 if (not $octet{$char}) {
6437 0         0 $delimiter = $char;
6438             $end_delimiter = $char;
6439             last;
6440             }
6441             }
6442             }
6443 0         0 }
6444 0         0  
6445             my $prematch = '';
6446             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6447 0 100       0 }
6448 68         168  
6449             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6450             my $metachar = qr/[\@\\|[\]{^]/oxms;
6451 68         293  
6452             # split regexp
6453             my @char = $string =~ /\G((?>
6454             [^\\\$\@\[\(] |
6455             \\ (?>[1-9][0-9]*) |
6456             \\g (?>\s*) (?>[1-9][0-9]*) |
6457             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6458             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6459             \\x (?>[0-9A-Fa-f]{1,2}) |
6460             \\ (?>[0-7]{2,3}) |
6461             \\c [\x40-\x5F] |
6462             \\x\{ (?>[0-9A-Fa-f]+) \} |
6463             \\o\{ (?>[0-7]+) \} |
6464             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6465             \\ $q_char |
6466             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6467             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6468             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6469             [\$\@] $qq_variable |
6470             \$ (?>\s* [0-9]+) |
6471             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6472             \$ \$ (?![\w\{]) |
6473             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6474             \[\^ |
6475             \[\: (?>[a-z]+) :\] |
6476             \[\:\^ (?>[a-z]+) :\] |
6477             \(\? |
6478             $q_char
6479             ))/oxmsg;
6480 68 50       16054  
6481 68         454 # choice again delimiter
  0         0  
6482 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6483 0         0 my %octet = map {$_ => 1} @char;
6484 0         0 if (not $octet{')'}) {
6485             $delimiter = '(';
6486             $end_delimiter = ')';
6487 0         0 }
6488 0         0 elsif (not $octet{'}'}) {
6489             $delimiter = '{';
6490             $end_delimiter = '}';
6491 0         0 }
6492 0         0 elsif (not $octet{']'}) {
6493             $delimiter = '[';
6494             $end_delimiter = ']';
6495 0         0 }
6496 0         0 elsif (not $octet{'>'}) {
6497             $delimiter = '<';
6498             $end_delimiter = '>';
6499 0         0 }
6500 0 0       0 else {
6501 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6502 0         0 if (not $octet{$char}) {
6503 0         0 $delimiter = $char;
6504             $end_delimiter = $char;
6505             last;
6506             }
6507             }
6508             }
6509             }
6510 0         0  
  68         137  
6511             # count '('
6512 253         428 my $parens = grep { $_ eq '(' } @char;
6513 68         104  
6514 68         113 my $left_e = 0;
6515             my $right_e = 0;
6516             for (my $i=0; $i <= $#char; $i++) {
6517 68 50 33     259  
    50 33        
    100          
    100          
    50          
    50          
6518 195         1163 # "\L\u" --> "\u\L"
6519             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6520             @char[$i,$i+1] = @char[$i+1,$i];
6521             }
6522              
6523 0         0 # "\U\l" --> "\l\U"
6524             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6525             @char[$i,$i+1] = @char[$i+1,$i];
6526             }
6527              
6528 0         0 # octal escape sequence
6529             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6530             $char[$i] = Elatin6::octchr($1);
6531             }
6532              
6533 1         3 # hexadecimal escape sequence
6534             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6535             $char[$i] = Elatin6::hexchr($1);
6536             }
6537              
6538             # \b{...} --> b\{...}
6539             # \B{...} --> B\{...}
6540             # \N{CHARNAME} --> N\{CHARNAME}
6541             # \p{PROPERTY} --> p\{PROPERTY}
6542 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6543             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6544             $char[$i] = $1 . '\\' . $2;
6545             }
6546              
6547 0         0 # \p, \P, \X --> p, P, X
6548             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6549             $char[$i] = $1;
6550 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          
6551              
6552             if (0) {
6553             }
6554 195         1053  
6555 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6556 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6557             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)) {
6558             $char[$i] .= join '', splice @char, $i+1, 3;
6559 0         0 }
6560             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)) {
6561             $char[$i] .= join '', splice @char, $i+1, 2;
6562 0         0 }
6563             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)) {
6564             $char[$i] .= join '', splice @char, $i+1, 1;
6565             }
6566             }
6567              
6568 0         0 # open character class [...]
6569 13 50       20 elsif ($char[$i] eq '[') {
6570 13         51 my $left = $i;
6571             if ($char[$i+1] eq ']') {
6572 0         0 $i++;
6573 13 50       18 }
6574 58         87 while (1) {
6575             if (++$i > $#char) {
6576 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6577 58         106 }
6578             if ($char[$i] eq ']') {
6579             my $right = $i;
6580 13 50       92  
6581 13         92 # [...]
  0         0  
6582             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6583             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);
6584 0         0 }
6585             else {
6586             splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
6587 13         63 }
6588 13         23  
6589             $i = $left;
6590             last;
6591             }
6592             }
6593             }
6594              
6595 13         37 # open character class [^...]
6596 0 0       0 elsif ($char[$i] eq '[^') {
6597 0         0 my $left = $i;
6598             if ($char[$i+1] eq ']') {
6599 0         0 $i++;
6600 0 0       0 }
6601 0         0 while (1) {
6602             if (++$i > $#char) {
6603 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6604 0         0 }
6605             if ($char[$i] eq ']') {
6606             my $right = $i;
6607 0 0       0  
6608 0         0 # [^...]
  0         0  
6609             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6610             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);
6611 0         0 }
6612             else {
6613             splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6614 0         0 }
6615 0         0  
6616             $i = $left;
6617             last;
6618             }
6619             }
6620             }
6621              
6622 0         0 # rewrite character class or escape character
6623             elsif (my $char = character_class($char[$i],$modifier)) {
6624             $char[$i] = $char;
6625             }
6626              
6627 7 50       16 # /i modifier
6628 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6629             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6630             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6631 3         5 }
6632             else {
6633             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
6634             }
6635             }
6636              
6637 0 0       0 # \u \l \U \L \F \Q \E
6638 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6639             if ($right_e < $left_e) {
6640             $char[$i] = '\\' . $char[$i];
6641             }
6642 0         0 }
6643 0         0 elsif ($char[$i] eq '\u') {
6644             $char[$i] = '@{[Elatin6::ucfirst qq<';
6645             $left_e++;
6646 0         0 }
6647 0         0 elsif ($char[$i] eq '\l') {
6648             $char[$i] = '@{[Elatin6::lcfirst qq<';
6649             $left_e++;
6650 0         0 }
6651 0         0 elsif ($char[$i] eq '\U') {
6652             $char[$i] = '@{[Elatin6::uc qq<';
6653             $left_e++;
6654 0         0 }
6655 0         0 elsif ($char[$i] eq '\L') {
6656             $char[$i] = '@{[Elatin6::lc qq<';
6657             $left_e++;
6658 0         0 }
6659 0         0 elsif ($char[$i] eq '\F') {
6660             $char[$i] = '@{[Elatin6::fc qq<';
6661             $left_e++;
6662 0         0 }
6663 0         0 elsif ($char[$i] eq '\Q') {
6664             $char[$i] = '@{[CORE::quotemeta qq<';
6665             $left_e++;
6666 0 0       0 }
6667 0         0 elsif ($char[$i] eq '\E') {
6668 0         0 if ($right_e < $left_e) {
6669             $char[$i] = '>]}';
6670             $right_e++;
6671 0         0 }
6672             else {
6673             $char[$i] = '';
6674             }
6675 0         0 }
6676 0 0       0 elsif ($char[$i] eq '\Q') {
6677 0         0 while (1) {
6678             if (++$i > $#char) {
6679 0 0       0 last;
6680 0         0 }
6681             if ($char[$i] eq '\E') {
6682             last;
6683             }
6684             }
6685             }
6686             elsif ($char[$i] eq '\E') {
6687             }
6688              
6689             # \0 --> \0
6690             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6691             }
6692              
6693             # \g{N}, \g{-N}
6694              
6695             # P.108 Using Simple Patterns
6696             # in Chapter 7: In the World of Regular Expressions
6697             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6698              
6699             # P.221 Capturing
6700             # in Chapter 5: Pattern Matching
6701             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6702              
6703             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6704             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6705             }
6706              
6707             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6708             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6709             }
6710              
6711             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6712             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6713             }
6714              
6715             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6716             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6717             }
6718              
6719 0 0       0 # $0 --> $0
6720 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6721             if ($ignorecase) {
6722             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6723             }
6724 0 0       0 }
6725 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6726             if ($ignorecase) {
6727             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6728             }
6729             }
6730              
6731             # $$ --> $$
6732             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6733             }
6734              
6735             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6736 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6737 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6738 0         0 $char[$i] = e_capture($1);
6739             if ($ignorecase) {
6740             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6741             }
6742 0         0 }
6743 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6744 0         0 $char[$i] = e_capture($1);
6745             if ($ignorecase) {
6746             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6747             }
6748             }
6749              
6750 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6751 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) {
6752 0         0 $char[$i] = e_capture($1.'->'.$2);
6753             if ($ignorecase) {
6754             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6755             }
6756             }
6757              
6758 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6759 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) {
6760 0         0 $char[$i] = e_capture($1.'->'.$2);
6761             if ($ignorecase) {
6762             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6763             }
6764             }
6765              
6766 0         0 # $$foo
6767 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6768 0         0 $char[$i] = e_capture($1);
6769             if ($ignorecase) {
6770             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6771             }
6772             }
6773              
6774 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
6775 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6776             if ($ignorecase) {
6777             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
6778 0         0 }
6779             else {
6780             $char[$i] = '@{[Elatin6::PREMATCH()]}';
6781             }
6782             }
6783              
6784 4 50       16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
6785 4         12 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6786             if ($ignorecase) {
6787             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
6788 0         0 }
6789             else {
6790             $char[$i] = '@{[Elatin6::MATCH()]}';
6791             }
6792             }
6793              
6794 4 50       14 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
6795 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6796             if ($ignorecase) {
6797             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
6798 0         0 }
6799             else {
6800             $char[$i] = '@{[Elatin6::POSTMATCH()]}';
6801             }
6802             }
6803              
6804 3 0       12 # ${ foo }
6805 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) {
6806             if ($ignorecase) {
6807             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6808             }
6809             }
6810              
6811 0         0 # ${ ... }
6812 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6813 0         0 $char[$i] = e_capture($1);
6814             if ($ignorecase) {
6815             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6816             }
6817             }
6818              
6819 0         0 # $scalar or @array
6820 4 50       22 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6821 4         21 $char[$i] = e_string($char[$i]);
6822             if ($ignorecase) {
6823             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6824             }
6825             }
6826              
6827 0 50       0 # quote character before ? + * {
6828             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6829             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6830 13         70 }
6831             else {
6832             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6833             }
6834             }
6835             }
6836 13         75  
6837 68         151 # make regexp string
6838 68 50       115 my $prematch = '';
6839 68         169 $modifier =~ tr/i//d;
6840             if ($left_e > $right_e) {
6841 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6842             }
6843             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6844             }
6845              
6846             #
6847             # escape regexp (s'here'' or s'here''b)
6848 68     21 0 759 #
6849 21   100     47 sub e_s1_q {
6850             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6851 21         61 $modifier ||= '';
6852 21 50       26  
6853 21         40 $modifier =~ tr/p//d;
6854 0         0 if ($modifier =~ /([adlu])/oxms) {
6855 0 0       0 my $line = 0;
6856 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6857 0         0 if ($filename ne __FILE__) {
6858             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6859             last;
6860 0         0 }
6861             }
6862             die qq{Unsupported modifier "$1" used at line $line.\n};
6863 0         0 }
6864              
6865             $slash = 'div';
6866 21 100       27  
    50          
6867 21         61 # literal null string pattern
6868 8         16 if ($string eq '') {
6869 8         11 $modifier =~ tr/bB//d;
6870             $modifier =~ tr/i//d;
6871             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6872             }
6873              
6874 8         43 # with /b /B modifier
6875             elsif ($modifier =~ tr/bB//d) {
6876             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6877             }
6878              
6879 0         0 # without /b /B modifier
6880             else {
6881             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6882             }
6883             }
6884              
6885             #
6886             # escape regexp (s'here'')
6887 13     13 0 31 #
6888             sub e_s1_qt {
6889 13 50       29 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6890              
6891             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6892 13         23  
6893             # split regexp
6894             my @char = $string =~ /\G((?>
6895             [^\\\[\$\@\/] |
6896             [\x00-\xFF] |
6897             \[\^ |
6898             \[\: (?>[a-z]+) \:\] |
6899             \[\:\^ (?>[a-z]+) \:\] |
6900             [\$\@\/] |
6901             \\ (?:$q_char) |
6902             (?:$q_char)
6903             ))/oxmsg;
6904 13         202  
6905 13 50 33     38 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6906             for (my $i=0; $i <= $#char; $i++) {
6907             if (0) {
6908             }
6909 25         132  
6910 0         0 # open character class [...]
6911 0 0       0 elsif ($char[$i] eq '[') {
6912 0         0 my $left = $i;
6913             if ($char[$i+1] eq ']') {
6914 0         0 $i++;
6915 0 0       0 }
6916 0         0 while (1) {
6917             if (++$i > $#char) {
6918 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6919 0         0 }
6920             if ($char[$i] eq ']') {
6921             my $right = $i;
6922 0         0  
6923             # [...]
6924 0         0 splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
6925 0         0  
6926             $i = $left;
6927             last;
6928             }
6929             }
6930             }
6931              
6932 0         0 # open character class [^...]
6933 0 0       0 elsif ($char[$i] eq '[^') {
6934 0         0 my $left = $i;
6935             if ($char[$i+1] eq ']') {
6936 0         0 $i++;
6937 0 0       0 }
6938 0         0 while (1) {
6939             if (++$i > $#char) {
6940 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6941 0         0 }
6942             if ($char[$i] eq ']') {
6943             my $right = $i;
6944 0         0  
6945             # [^...]
6946 0         0 splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6947 0         0  
6948             $i = $left;
6949             last;
6950             }
6951             }
6952             }
6953              
6954 0         0 # escape $ @ / and \
6955             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6956             $char[$i] = '\\' . $char[$i];
6957             }
6958              
6959 0         0 # rewrite character class or escape character
6960             elsif (my $char = character_class($char[$i],$modifier)) {
6961             $char[$i] = $char;
6962             }
6963              
6964 6 0       13 # /i modifier
6965 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6966             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6967             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6968 0         0 }
6969             else {
6970             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
6971             }
6972             }
6973              
6974 0 0       0 # quote character before ? + * {
6975             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6976             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6977 0         0 }
6978             else {
6979             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6980             }
6981             }
6982 0         0 }
6983 13         24  
6984 13         19 $modifier =~ tr/i//d;
6985 13         16 $delimiter = '/';
6986 13         16 $end_delimiter = '/';
6987             my $prematch = '';
6988             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6989             }
6990              
6991             #
6992             # escape regexp (s'here''b)
6993 13     0 0 89 #
6994             sub e_s1_qb {
6995             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6996 0         0  
6997             # split regexp
6998             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6999 0         0  
7000 0 0       0 # unescape character
    0          
7001             for (my $i=0; $i <= $#char; $i++) {
7002             if (0) {
7003             }
7004 0         0  
7005             # remain \\
7006             elsif ($char[$i] eq '\\\\') {
7007             }
7008              
7009 0         0 # escape $ @ / and \
7010             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7011             $char[$i] = '\\' . $char[$i];
7012             }
7013 0         0 }
7014 0         0  
7015 0         0 $delimiter = '/';
7016 0         0 $end_delimiter = '/';
7017             my $prematch = '';
7018             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7019             }
7020              
7021             #
7022             # escape regexp (s''here')
7023 0     16 0 0 #
7024             sub e_s2_q {
7025 16         31 my($ope,$delimiter,$end_delimiter,$string) = @_;
7026              
7027 16         19 $slash = 'div';
7028 16         90  
7029 16 100       40 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7030             for (my $i=0; $i <= $#char; $i++) {
7031             if (0) {
7032             }
7033 9         32  
7034             # not escape \\
7035             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7036             }
7037              
7038 0         0 # escape $ @ / and \
7039             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7040             $char[$i] = '\\' . $char[$i];
7041             }
7042 5         15 }
7043              
7044             return join '', $ope, $delimiter, @char, $end_delimiter;
7045             }
7046              
7047             #
7048             # escape regexp (s/here/and here/modifier)
7049 16     97 0 45 #
7050 97   100     862 sub e_sub {
7051             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7052 97         434 $modifier ||= '';
7053 97 50       172  
7054 97         263 $modifier =~ tr/p//d;
7055 0         0 if ($modifier =~ /([adlu])/oxms) {
7056 0 0       0 my $line = 0;
7057 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7058 0         0 if ($filename ne __FILE__) {
7059             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7060             last;
7061 0         0 }
7062             }
7063             die qq{Unsupported modifier "$1" used at line $line.\n};
7064 0 100       0 }
7065 97         242  
7066 36         45 if ($variable eq '') {
7067             $variable = '$_';
7068             $bind_operator = ' =~ ';
7069 36         53 }
7070              
7071             $slash = 'div';
7072              
7073             # P.128 Start of match (or end of previous match): \G
7074             # P.130 Advanced Use of \G with Perl
7075             # in Chapter 3: Overview of Regular Expression Features and Flavors
7076             # P.312 Iterative Matching: Scalar Context, with /g
7077             # in Chapter 7: Perl
7078             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7079              
7080             # P.181 Where You Left Off: The \G Assertion
7081             # in Chapter 5: Pattern Matching
7082             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7083              
7084             # P.220 Where You Left Off: The \G Assertion
7085             # in Chapter 5: Pattern Matching
7086 97         139 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7087 97         168  
7088             my $e_modifier = $modifier =~ tr/e//d;
7089 97         156 my $r_modifier = $modifier =~ tr/r//d;
7090 97 50       135  
7091 97         234 my $my = '';
7092 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7093 0         0 $my = $variable;
7094             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7095             $variable =~ s/ = .+ \z//oxms;
7096 0         0 }
7097 97         238  
7098             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7099             $variable_basename =~ s/ \s+ \z//oxms;
7100 97         292  
7101 97 100       152 # quote replacement string
7102 97         244 my $e_replacement = '';
7103 17         34 if ($e_modifier >= 1) {
7104             $e_replacement = e_qq('', '', '', $replacement);
7105             $e_modifier--;
7106 17 100       24 }
7107 80         187 else {
7108             if ($delimiter2 eq "'") {
7109             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7110 16         28 }
7111             else {
7112             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7113             }
7114 64         161 }
7115              
7116             my $sub = '';
7117 97 100       155  
7118 97 100       239 # with /r
7119             if ($r_modifier) {
7120             if (0) {
7121             }
7122 8         15  
7123 0 50       0 # s///gr without multibyte anchoring
7124             elsif ($modifier =~ /g/oxms) {
7125             $sub = sprintf(
7126             # 1 2 3 4 5
7127             q,
7128              
7129             $variable, # 1
7130             ($delimiter1 eq "'") ? # 2
7131             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7132             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7133             $s_matched, # 3
7134             $e_replacement, # 4
7135             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 5
7136             );
7137             }
7138              
7139             # s///r
7140 4         15 else {
7141              
7142 4 50       6 my $prematch = q{$`};
7143              
7144             $sub = sprintf(
7145             # 1 2 3 4 5 6 7
7146             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin6::re_r=%s; %s"%s$Elatin6::re_r$'" } : %s>,
7147              
7148             $variable, # 1
7149             ($delimiter1 eq "'") ? # 2
7150             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7151             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7152             $s_matched, # 3
7153             $e_replacement, # 4
7154             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 5
7155             $prematch, # 6
7156             $variable, # 7
7157             );
7158             }
7159 4 50       10  
7160 8         22 # $var !~ s///r doesn't make sense
7161             if ($bind_operator =~ / !~ /oxms) {
7162             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7163             }
7164             }
7165              
7166 0 100       0 # without /r
7167             else {
7168             if (0) {
7169             }
7170 89         216  
7171 0 100       0 # s///g without multibyte anchoring
    100          
7172             elsif ($modifier =~ /g/oxms) {
7173             $sub = sprintf(
7174             # 1 2 3 4 5 6 7 8
7175             q,
7176              
7177             $variable, # 1
7178             ($delimiter1 eq "'") ? # 2
7179             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7180             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7181             $s_matched, # 3
7182             $e_replacement, # 4
7183             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 5
7184             $variable, # 6
7185             $variable, # 7
7186             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7187             );
7188             }
7189              
7190             # s///
7191 22         80 else {
7192              
7193 67 100       107 my $prematch = q{$`};
    100          
7194              
7195             $sub = sprintf(
7196              
7197             ($bind_operator =~ / =~ /oxms) ?
7198              
7199             # 1 2 3 4 5 6 7 8
7200             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin6::re_r=%s; %s%s="%s$Elatin6::re_r$'"; 1 } : undef> :
7201              
7202             # 1 2 3 4 5 6 7 8
7203             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin6::re_r=%s; %s%s="%s$Elatin6::re_r$'"; undef }>,
7204              
7205             $variable, # 1
7206             $bind_operator, # 2
7207             ($delimiter1 eq "'") ? # 3
7208             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7209             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7210             $s_matched, # 4
7211             $e_replacement, # 5
7212             '$Elatin6::re_r=CORE::eval $Elatin6::re_r; ' x $e_modifier, # 6
7213             $variable, # 7
7214             $prematch, # 8
7215             );
7216             }
7217             }
7218 67 50       455  
7219 97         264 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7220             if ($my ne '') {
7221             $sub = "($my, $sub)[1]";
7222             }
7223 0         0  
7224 97         154 # clear s/// variable
7225             $sub_variable = '';
7226 97         121 $bind_operator = '';
7227              
7228             return $sub;
7229             }
7230              
7231             #
7232             # escape regexp of split qr//
7233 97     74 0 682 #
7234 74   100     398 sub e_split {
7235             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7236 74         352 $modifier ||= '';
7237 74 50       131  
7238 74         176 $modifier =~ tr/p//d;
7239 0         0 if ($modifier =~ /([adlu])/oxms) {
7240 0 0       0 my $line = 0;
7241 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7242 0         0 if ($filename ne __FILE__) {
7243             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7244             last;
7245 0         0 }
7246             }
7247             die qq{Unsupported modifier "$1" used at line $line.\n};
7248 0         0 }
7249              
7250             $slash = 'div';
7251 74 50       126  
7252 74         207 # /b /B modifier
7253             if ($modifier =~ tr/bB//d) {
7254             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7255 0 50       0 }
7256 74         170  
7257             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7258             my $metachar = qr/[\@\\|[\]{^]/oxms;
7259 74         260  
7260             # split regexp
7261             my @char = $string =~ /\G((?>
7262             [^\\\$\@\[\(] |
7263             \\x (?>[0-9A-Fa-f]{1,2}) |
7264             \\ (?>[0-7]{2,3}) |
7265             \\c [\x40-\x5F] |
7266             \\x\{ (?>[0-9A-Fa-f]+) \} |
7267             \\o\{ (?>[0-7]+) \} |
7268             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7269             \\ $q_char |
7270             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7271             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7272             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7273             [\$\@] $qq_variable |
7274             \$ (?>\s* [0-9]+) |
7275             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7276             \$ \$ (?![\w\{]) |
7277             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7278             \[\^ |
7279             \[\: (?>[a-z]+) :\] |
7280             \[\:\^ (?>[a-z]+) :\] |
7281             \(\? |
7282             $q_char
7283 74         8788 ))/oxmsg;
7284 74         319  
7285 74         112 my $left_e = 0;
7286             my $right_e = 0;
7287             for (my $i=0; $i <= $#char; $i++) {
7288 74 50 33     358  
    50 33        
    100          
    100          
    50          
    50          
7289 249         1276 # "\L\u" --> "\u\L"
7290             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7291             @char[$i,$i+1] = @char[$i+1,$i];
7292             }
7293              
7294 0         0 # "\U\l" --> "\l\U"
7295             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7296             @char[$i,$i+1] = @char[$i+1,$i];
7297             }
7298              
7299 0         0 # octal escape sequence
7300             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7301             $char[$i] = Elatin6::octchr($1);
7302             }
7303              
7304 1         3 # hexadecimal escape sequence
7305             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7306             $char[$i] = Elatin6::hexchr($1);
7307             }
7308              
7309             # \b{...} --> b\{...}
7310             # \B{...} --> B\{...}
7311             # \N{CHARNAME} --> N\{CHARNAME}
7312             # \p{PROPERTY} --> p\{PROPERTY}
7313 1         3 # \P{PROPERTY} --> P\{PROPERTY}
7314             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7315             $char[$i] = $1 . '\\' . $2;
7316             }
7317              
7318 0         0 # \p, \P, \X --> p, P, X
7319             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7320             $char[$i] = $1;
7321 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          
7322              
7323             if (0) {
7324             }
7325 249         836  
7326 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7327 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7328             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)) {
7329             $char[$i] .= join '', splice @char, $i+1, 3;
7330 0         0 }
7331             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)) {
7332             $char[$i] .= join '', splice @char, $i+1, 2;
7333 0         0 }
7334             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)) {
7335             $char[$i] .= join '', splice @char, $i+1, 1;
7336             }
7337             }
7338              
7339 0         0 # open character class [...]
7340 3 50       7 elsif ($char[$i] eq '[') {
7341 3         11 my $left = $i;
7342             if ($char[$i+1] eq ']') {
7343 0         0 $i++;
7344 3 50       5 }
7345 7         12 while (1) {
7346             if (++$i > $#char) {
7347 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7348 7         24 }
7349             if ($char[$i] eq ']') {
7350             my $right = $i;
7351 3 50       3  
7352 3         20 # [...]
  0         0  
7353             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7354             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);
7355 0         0 }
7356             else {
7357             splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
7358 3         46 }
7359 3         6  
7360             $i = $left;
7361             last;
7362             }
7363             }
7364             }
7365              
7366 3         7 # open character class [^...]
7367 0 0       0 elsif ($char[$i] eq '[^') {
7368 0         0 my $left = $i;
7369             if ($char[$i+1] eq ']') {
7370 0         0 $i++;
7371 0 0       0 }
7372 0         0 while (1) {
7373             if (++$i > $#char) {
7374 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7375 0         0 }
7376             if ($char[$i] eq ']') {
7377             my $right = $i;
7378 0 0       0  
7379 0         0 # [^...]
  0         0  
7380             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7381             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);
7382 0         0 }
7383             else {
7384             splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7385 0         0 }
7386 0         0  
7387             $i = $left;
7388             last;
7389             }
7390             }
7391             }
7392              
7393 0         0 # rewrite character class or escape character
7394             elsif (my $char = character_class($char[$i],$modifier)) {
7395             $char[$i] = $char;
7396             }
7397              
7398             # P.794 29.2.161. split
7399             # in Chapter 29: Functions
7400             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7401              
7402             # P.951 split
7403             # in Chapter 27: Functions
7404             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7405              
7406             # said "The //m modifier is assumed when you split on the pattern /^/",
7407             # but perl5.008 is not so. Therefore, this software adds //m.
7408             # (and so on)
7409              
7410 1         2 # split(m/^/) --> split(m/^/m)
7411             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7412             $modifier .= 'm';
7413             }
7414              
7415 7 0       22 # /i modifier
7416 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
7417             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
7418             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
7419 0         0 }
7420             else {
7421             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
7422             }
7423             }
7424              
7425 0 0       0 # \u \l \U \L \F \Q \E
7426 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7427             if ($right_e < $left_e) {
7428             $char[$i] = '\\' . $char[$i];
7429             }
7430 0         0 }
7431 0         0 elsif ($char[$i] eq '\u') {
7432             $char[$i] = '@{[Elatin6::ucfirst qq<';
7433             $left_e++;
7434 0         0 }
7435 0         0 elsif ($char[$i] eq '\l') {
7436             $char[$i] = '@{[Elatin6::lcfirst qq<';
7437             $left_e++;
7438 0         0 }
7439 0         0 elsif ($char[$i] eq '\U') {
7440             $char[$i] = '@{[Elatin6::uc qq<';
7441             $left_e++;
7442 0         0 }
7443 0         0 elsif ($char[$i] eq '\L') {
7444             $char[$i] = '@{[Elatin6::lc qq<';
7445             $left_e++;
7446 0         0 }
7447 0         0 elsif ($char[$i] eq '\F') {
7448             $char[$i] = '@{[Elatin6::fc qq<';
7449             $left_e++;
7450 0         0 }
7451 0         0 elsif ($char[$i] eq '\Q') {
7452             $char[$i] = '@{[CORE::quotemeta qq<';
7453             $left_e++;
7454 0 0       0 }
7455 0         0 elsif ($char[$i] eq '\E') {
7456 0         0 if ($right_e < $left_e) {
7457             $char[$i] = '>]}';
7458             $right_e++;
7459 0         0 }
7460             else {
7461             $char[$i] = '';
7462             }
7463 0         0 }
7464 0 0       0 elsif ($char[$i] eq '\Q') {
7465 0         0 while (1) {
7466             if (++$i > $#char) {
7467 0 0       0 last;
7468 0         0 }
7469             if ($char[$i] eq '\E') {
7470             last;
7471             }
7472             }
7473             }
7474             elsif ($char[$i] eq '\E') {
7475             }
7476              
7477 0 0       0 # $0 --> $0
7478 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7479             if ($ignorecase) {
7480             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7481             }
7482 0 0       0 }
7483 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7484             if ($ignorecase) {
7485             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7486             }
7487             }
7488              
7489             # $$ --> $$
7490             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7491             }
7492              
7493             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7494 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7495 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7496 0         0 $char[$i] = e_capture($1);
7497             if ($ignorecase) {
7498             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7499             }
7500 0         0 }
7501 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7502 0         0 $char[$i] = e_capture($1);
7503             if ($ignorecase) {
7504             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7505             }
7506             }
7507              
7508 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7509 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) {
7510 0         0 $char[$i] = e_capture($1.'->'.$2);
7511             if ($ignorecase) {
7512             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7513             }
7514             }
7515              
7516 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7517 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) {
7518 0         0 $char[$i] = e_capture($1.'->'.$2);
7519             if ($ignorecase) {
7520             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7521             }
7522             }
7523              
7524 0         0 # $$foo
7525 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7526 0         0 $char[$i] = e_capture($1);
7527             if ($ignorecase) {
7528             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7529             }
7530             }
7531              
7532 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
7533 12         34 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7534             if ($ignorecase) {
7535             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
7536 0         0 }
7537             else {
7538             $char[$i] = '@{[Elatin6::PREMATCH()]}';
7539             }
7540             }
7541              
7542 12 50       48 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
7543 12         35 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7544             if ($ignorecase) {
7545             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
7546 0         0 }
7547             else {
7548             $char[$i] = '@{[Elatin6::MATCH()]}';
7549             }
7550             }
7551              
7552 12 50       50 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
7553 9         43 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7554             if ($ignorecase) {
7555             $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
7556 0         0 }
7557             else {
7558             $char[$i] = '@{[Elatin6::POSTMATCH()]}';
7559             }
7560             }
7561              
7562 9 0       39 # ${ foo }
7563 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) {
7564             if ($ignorecase) {
7565             $char[$i] = '@{[Elatin6::ignorecase(' . $1 . ')]}';
7566             }
7567             }
7568              
7569 0         0 # ${ ... }
7570 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7571 0         0 $char[$i] = e_capture($1);
7572             if ($ignorecase) {
7573             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7574             }
7575             }
7576              
7577 0         0 # $scalar or @array
7578 3 50       8 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7579 3         13 $char[$i] = e_string($char[$i]);
7580             if ($ignorecase) {
7581             $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7582             }
7583             }
7584              
7585 0 50       0 # quote character before ? + * {
7586             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7587             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7588 1         7 }
7589             else {
7590             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7591             }
7592             }
7593             }
7594 0         0  
7595 74 50       198 # make regexp string
7596 74         161 $modifier =~ tr/i//d;
7597             if ($left_e > $right_e) {
7598 0         0 return join '', 'Elatin6::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7599             }
7600             return join '', 'Elatin6::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7601             }
7602              
7603             #
7604             # escape regexp of split qr''
7605 74     0 0 722 #
7606 0   0       sub e_split_q {
7607             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7608 0           $modifier ||= '';
7609 0 0          
7610 0           $modifier =~ tr/p//d;
7611 0           if ($modifier =~ /([adlu])/oxms) {
7612 0 0         my $line = 0;
7613 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7614 0           if ($filename ne __FILE__) {
7615             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7616             last;
7617 0           }
7618             }
7619             die qq{Unsupported modifier "$1" used at line $line.\n};
7620 0           }
7621              
7622             $slash = 'div';
7623 0 0          
7624 0           # /b /B modifier
7625             if ($modifier =~ tr/bB//d) {
7626             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7627 0 0         }
7628              
7629             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7630 0            
7631             # split regexp
7632             my @char = $string =~ /\G((?>
7633             [^\\\[] |
7634             [\x00-\xFF] |
7635             \[\^ |
7636             \[\: (?>[a-z]+) \:\] |
7637             \[\:\^ (?>[a-z]+) \:\] |
7638             \\ (?:$q_char) |
7639             (?:$q_char)
7640             ))/oxmsg;
7641 0            
7642 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7643             for (my $i=0; $i <= $#char; $i++) {
7644             if (0) {
7645             }
7646 0            
7647 0           # open character class [...]
7648 0 0         elsif ($char[$i] eq '[') {
7649 0           my $left = $i;
7650             if ($char[$i+1] eq ']') {
7651 0           $i++;
7652 0 0         }
7653 0           while (1) {
7654             if (++$i > $#char) {
7655 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7656 0           }
7657             if ($char[$i] eq ']') {
7658             my $right = $i;
7659 0            
7660             # [...]
7661 0           splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
7662 0            
7663             $i = $left;
7664             last;
7665             }
7666             }
7667             }
7668              
7669 0           # open character class [^...]
7670 0 0         elsif ($char[$i] eq '[^') {
7671 0           my $left = $i;
7672             if ($char[$i+1] eq ']') {
7673 0           $i++;
7674 0 0         }
7675 0           while (1) {
7676             if (++$i > $#char) {
7677 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7678 0           }
7679             if ($char[$i] eq ']') {
7680             my $right = $i;
7681 0            
7682             # [^...]
7683 0           splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7684 0            
7685             $i = $left;
7686             last;
7687             }
7688             }
7689             }
7690              
7691 0           # rewrite character class or escape character
7692             elsif (my $char = character_class($char[$i],$modifier)) {
7693             $char[$i] = $char;
7694             }
7695              
7696 0           # split(m/^/) --> split(m/^/m)
7697             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7698             $modifier .= 'm';
7699             }
7700              
7701 0 0         # /i modifier
7702 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
7703             if (CORE::length(Elatin6::fc($char[$i])) == 1) {
7704             $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
7705 0           }
7706             else {
7707             $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
7708             }
7709             }
7710              
7711 0 0         # quote character before ? + * {
7712             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7713             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7714 0           }
7715             else {
7716             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7717             }
7718             }
7719 0           }
7720 0            
7721             $modifier =~ tr/i//d;
7722             return join '', 'Elatin6::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7723             }
7724              
7725             #
7726             # instead of Carp::carp
7727 0     0 0   #
7728 0           sub carp {
7729             my($package,$filename,$line) = caller(1);
7730             print STDERR "@_ at $filename line $line.\n";
7731             }
7732              
7733             #
7734             # instead of Carp::croak
7735 0     0 0   #
7736 0           sub croak {
7737 0           my($package,$filename,$line) = caller(1);
7738             print STDERR "@_ at $filename line $line.\n";
7739             die "\n";
7740             }
7741              
7742             #
7743             # instead of Carp::cluck
7744 0     0 0   #
7745 0           sub cluck {
7746 0           my $i = 0;
7747 0           my @cluck = ();
7748 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7749             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7750 0           $i++;
7751 0           }
7752 0           print STDERR CORE::reverse @cluck;
7753             print STDERR "\n";
7754             print STDERR @_;
7755             }
7756              
7757             #
7758             # instead of Carp::confess
7759 0     0 0   #
7760 0           sub confess {
7761 0           my $i = 0;
7762 0           my @confess = ();
7763 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7764             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7765 0           $i++;
7766 0           }
7767 0           print STDERR CORE::reverse @confess;
7768 0           print STDERR "\n";
7769             print STDERR @_;
7770             die "\n";
7771             }
7772              
7773             1;
7774              
7775             __END__