File Coverage

blib/lib/Elatin6.pm
Criterion Covered Total %
statement 83 3085 2.6
branch 4 2674 0.1
condition 1 373 0.2
subroutine 36 125 28.8
pod 7 74 9.4
total 131 6331 2.0


line stmt bran cond sub pod time code
1             package Elatin6;
2             ######################################################################
3             #
4             # Elatin6 - Run-time routines for Latin6.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin6/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
9             ######################################################################
10              
11 200     200   5124 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         630  
  200         11784  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             # 12.3. Delaying use Until Runtime
15             # in Chapter 12. Packages, Libraries, and Modules
16             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
17             # (and so on)
18              
19             # Version numbers should be boring
20             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
21             # For the impatient, the disinterested or those who just want to follow
22             # a recipe, my advice for all modules is this:
23             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
24             # $VERSION = eval $VERSION;
25              
26 200     200   15782 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1227  
  200         349  
  200         34127  
27             $VERSION = '1.05';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1771 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         450 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         34176 if (CORE::ord('A') != 0x41) {
38             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
39             }
40             }
41              
42             BEGIN {
43              
44             # instead of utf8.pm
45 200     200   16486 CORE::eval q{
  200     200   1451  
  200     60   332  
  200         30026  
  60         11902  
  64         13720  
  61         12272  
  62         11375  
  81         15029  
  72         13333  
46             no warnings qw(redefine);
47             *utf8::upgrade = sub { CORE::length $_[0] };
48             *utf8::downgrade = sub { 1 };
49             *utf8::encode = sub { };
50             *utf8::decode = sub { 1 };
51             *utf8::is_utf8 = sub { };
52             *utf8::valid = sub { 1 };
53             };
54 200 50       121660 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
  0         0  
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
  0         0  
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65             BEGIN {
66 200     200   615 my $genpkg = "Symbol::";
67 200         10109 my $genseq = 0;
68              
69             sub gensym () {
70 0     0 0 0 my $name = "GEN" . $genseq++;
71              
72             # here, no strict qw(refs); if strict.pm exists
73              
74 0         0 my $ref = \*{$genpkg . $name};
  0         0  
75 0         0 delete $$genpkg{$name};
76 0         0 return $ref;
77             }
78              
79             sub qualify ($;$) {
80 0     0 0 0 my ($name) = @_;
81 0 0 0     0 if (!ref($name) && (Elatin6::index($name, '::') == -1) && (Elatin6::index($name, "'") == -1)) {
      0        
82 0         0 my $pkg;
83 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
84              
85             # Global names: special character, "^xyz", or other.
86 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
89 0         0 $pkg = "main";
90             }
91             else {
92 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
93             }
94 0         0 $name = $pkg . "::" . $name;
95             }
96 0         0 return $name;
97             }
98              
99             sub qualify_to_ref ($;$) {
100              
101             # here, no strict qw(refs); if strict.pm exists
102              
103 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
104             }
105             }
106              
107             # Column: local $@
108             # in Chapter 9. Osaete okitai Perl no kiso
109             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
110             # (and so on)
111              
112             # use strict; if strict.pm exists
113             BEGIN {
114 200 50   200   408 if (CORE::eval { local $@; CORE::require strict }) {
  200         595  
  200         2178  
115 200         27386 strict::->import;
116             }
117             }
118              
119             # P.714 29.2.39. flock
120             # in Chapter 29: Functions
121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
122              
123             # P.863 flock
124             # in Chapter 27: Functions
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126              
127             sub LOCK_SH() {1}
128             sub LOCK_EX() {2}
129             sub LOCK_UN() {8}
130             sub LOCK_NB() {4}
131              
132             # instead of Carp.pm
133             sub carp;
134             sub croak;
135             sub cluck;
136             sub confess;
137              
138             # 6.18. Matching Multiple-Byte Characters
139             # in Chapter 6. Pattern Matching
140             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
141             # (and so on)
142              
143             # regexp of character
144 200     200   15520 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1387  
  200         346  
  200         14273  
145 200     200   14369 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   1219  
  200         289  
  200         15752  
146 200     200   13729 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   1119  
  200         317  
  200         15993  
147              
148             #
149             # Latin-6 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   15250 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   1107  
  200         325  
  200         487489  
157              
158             #
159             # Latin-6 case conversion
160             #
161             my %lc = ();
162             @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)} =
163             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             my %uc = ();
165             @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)} =
166             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
167             my %fc = ();
168             @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)} =
169             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
170              
171             if (0) {
172             }
173              
174             elsif (__PACKAGE__ =~ / \b Elatin6 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-10 | iec[- ]?8859-10 | latin-?6 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA1" => "\xB1", # LATIN LETTER A WITH OGONEK
183             "\xA2" => "\xB2", # LATIN LETTER E WITH MACRON
184             "\xA3" => "\xB3", # LATIN LETTER G WITH CEDILLA
185             "\xA4" => "\xB4", # LATIN LETTER I WITH MACRON
186             "\xA5" => "\xB5", # LATIN LETTER I WITH TILDE
187             "\xA6" => "\xB6", # LATIN LETTER K WITH CEDILLA
188             "\xA8" => "\xB8", # LATIN LETTER L WITH CEDILLA
189             "\xA9" => "\xB9", # LATIN LETTER D WITH STROKE
190             "\xAA" => "\xBA", # LATIN LETTER S WITH CARON
191             "\xAB" => "\xBB", # LATIN LETTER T WITH STROKE
192             "\xAC" => "\xBC", # LATIN LETTER Z WITH CARON
193             "\xAE" => "\xBE", # LATIN LETTER U WITH MACRON
194             "\xAF" => "\xBF", # LATIN LETTER ENG
195             "\xC0" => "\xE0", # LATIN LETTER A WITH MACRON
196             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
197             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
198             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
199             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
200             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
201             "\xC6" => "\xE6", # LATIN LETTER AE
202             "\xC7" => "\xE7", # LATIN LETTER I WITH OGONEK
203             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
204             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
205             "\xCA" => "\xEA", # LATIN LETTER E WITH OGONEK
206             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
207             "\xCC" => "\xEC", # LATIN LETTER E WITH DOT ABOVE
208             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
209             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
210             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
211             "\xD0" => "\xF0", # LATIN LETTER ETH (Icelandic)
212             "\xD1" => "\xF1", # LATIN LETTER N WITH CEDILLA
213             "\xD2" => "\xF2", # LATIN LETTER O WITH MACRON
214             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
215             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
216             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
217             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
218             "\xD7" => "\xF7", # LATIN LETTER U WITH TILDE
219             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
220             "\xD9" => "\xF9", # LATIN LETTER U WITH OGONEK
221             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
222             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
223             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
224             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
225             "\xDE" => "\xFE", # LATIN LETTER THORN (Icelandic)
226             );
227              
228             %uc = (%uc,
229             "\xB1" => "\xA1", # LATIN LETTER A WITH OGONEK
230             "\xB2" => "\xA2", # LATIN LETTER E WITH MACRON
231             "\xB3" => "\xA3", # LATIN LETTER G WITH CEDILLA
232             "\xB4" => "\xA4", # LATIN LETTER I WITH MACRON
233             "\xB5" => "\xA5", # LATIN LETTER I WITH TILDE
234             "\xB6" => "\xA6", # LATIN LETTER K WITH CEDILLA
235             "\xB8" => "\xA8", # LATIN LETTER L WITH CEDILLA
236             "\xB9" => "\xA9", # LATIN LETTER D WITH STROKE
237             "\xBA" => "\xAA", # LATIN LETTER S WITH CARON
238             "\xBB" => "\xAB", # LATIN LETTER T WITH STROKE
239             "\xBC" => "\xAC", # LATIN LETTER Z WITH CARON
240             "\xBE" => "\xAE", # LATIN LETTER U WITH MACRON
241             "\xBF" => "\xAF", # LATIN LETTER ENG
242             "\xE0" => "\xC0", # LATIN LETTER A WITH MACRON
243             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
244             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
245             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
246             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
247             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
248             "\xE6" => "\xC6", # LATIN LETTER AE
249             "\xE7" => "\xC7", # LATIN LETTER I WITH OGONEK
250             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
251             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
252             "\xEA" => "\xCA", # LATIN LETTER E WITH OGONEK
253             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
254             "\xEC" => "\xCC", # LATIN LETTER E WITH DOT ABOVE
255             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
256             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
257             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
258             "\xF0" => "\xD0", # LATIN LETTER ETH (Icelandic)
259             "\xF1" => "\xD1", # LATIN LETTER N WITH CEDILLA
260             "\xF2" => "\xD2", # LATIN LETTER O WITH MACRON
261             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
262             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
263             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
264             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
265             "\xF7" => "\xD7", # LATIN LETTER U WITH TILDE
266             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
267             "\xF9" => "\xD9", # LATIN LETTER U WITH OGONEK
268             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
269             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
270             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
271             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
272             "\xFE" => "\xDE", # LATIN LETTER THORN (Icelandic)
273             );
274              
275             %fc = (%fc,
276             "\xA1" => "\xB1", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
277             "\xA2" => "\xB2", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
278             "\xA3" => "\xB3", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
279             "\xA4" => "\xB4", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
280             "\xA5" => "\xB5", # LATIN CAPITAL LETTER I WITH TILDE --> LATIN SMALL LETTER I WITH TILDE
281             "\xA6" => "\xB6", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
282             "\xA8" => "\xB8", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
283             "\xA9" => "\xB9", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
284             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
285             "\xAB" => "\xBB", # LATIN CAPITAL LETTER T WITH STROKE --> LATIN SMALL LETTER T WITH STROKE
286             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
287             "\xAE" => "\xBE", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
288             "\xAF" => "\xBF", # LATIN CAPITAL LETTER ENG --> LATIN SMALL LETTER ENG
289             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
290             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
291             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
292             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
293             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
294             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
295             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
296             "\xC7" => "\xE7", # LATIN CAPITAL LETTER I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
297             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
298             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
299             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
300             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
301             "\xCC" => "\xEC", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
302             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
303             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
304             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
305             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
306             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
307             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
308             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
309             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
310             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
311             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
312             "\xD7" => "\xF7", # LATIN CAPITAL LETTER U WITH TILDE --> LATIN SMALL LETTER U WITH TILDE
313             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
314             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
315             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
316             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
317             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
318             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
319             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
320             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
321             );
322             }
323              
324             else {
325             croak "Don't know my package name '@{[__PACKAGE__]}'";
326             }
327              
328             #
329             # @ARGV wildcard globbing
330             #
331             sub import {
332              
333 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
334 0         0 my @argv = ();
335 0         0 for (@ARGV) {
336              
337             # has space
338 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
339 0 0       0 if (my @glob = Elatin6::glob(qq{"$_"})) {
340 0         0 push @argv, @glob;
341             }
342             else {
343 0         0 push @argv, $_;
344             }
345             }
346              
347             # has wildcard metachar
348             elsif (/\A (?:$q_char)*? [*?] /oxms) {
349 0 0       0 if (my @glob = Elatin6::glob($_)) {
350 0         0 push @argv, @glob;
351             }
352             else {
353 0         0 push @argv, $_;
354             }
355             }
356              
357             # no wildcard globbing
358             else {
359 0         0 push @argv, $_;
360             }
361             }
362 0         0 @ARGV = @argv;
363             }
364              
365 0         0 *Char::ord = \&Latin6::ord;
366 0         0 *Char::ord_ = \&Latin6::ord_;
367 0         0 *Char::reverse = \&Latin6::reverse;
368 0         0 *Char::getc = \&Latin6::getc;
369 0         0 *Char::length = \&Latin6::length;
370 0         0 *Char::substr = \&Latin6::substr;
371 0         0 *Char::index = \&Latin6::index;
372 0         0 *Char::rindex = \&Latin6::rindex;
373 0         0 *Char::eval = \&Latin6::eval;
374 0         0 *Char::escape = \&Latin6::escape;
375 0         0 *Char::escape_token = \&Latin6::escape_token;
376 0         0 *Char::escape_script = \&Latin6::escape_script;
377             }
378              
379             # P.230 Care with Prototypes
380             # in Chapter 6: Subroutines
381             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
382             #
383             # If you aren't careful, you can get yourself into trouble with prototypes.
384             # But if you are careful, you can do a lot of neat things with them. This is
385             # all very powerful, of course, and should only be used in moderation to make
386             # the world a better place.
387              
388             # P.332 Care with Prototypes
389             # in Chapter 7: Subroutines
390             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
391             #
392             # If you aren't careful, you can get yourself into trouble with prototypes.
393             # But if you are careful, you can do a lot of neat things with them. This is
394             # all very powerful, of course, and should only be used in moderation to make
395             # the world a better place.
396              
397             #
398             # Prototypes of subroutines
399             #
400 0     0   0 sub unimport {}
401             sub Elatin6::split(;$$$);
402             sub Elatin6::tr($$$$;$);
403             sub Elatin6::chop(@);
404             sub Elatin6::index($$;$);
405             sub Elatin6::rindex($$;$);
406             sub Elatin6::lcfirst(@);
407             sub Elatin6::lcfirst_();
408             sub Elatin6::lc(@);
409             sub Elatin6::lc_();
410             sub Elatin6::ucfirst(@);
411             sub Elatin6::ucfirst_();
412             sub Elatin6::uc(@);
413             sub Elatin6::uc_();
414             sub Elatin6::fc(@);
415             sub Elatin6::fc_();
416             sub Elatin6::ignorecase;
417             sub Elatin6::classic_character_class;
418             sub Elatin6::capture;
419             sub Elatin6::chr(;$);
420             sub Elatin6::chr_();
421             sub Elatin6::glob($);
422             sub Elatin6::glob_();
423              
424             sub Latin6::ord(;$);
425             sub Latin6::ord_();
426             sub Latin6::reverse(@);
427             sub Latin6::getc(;*@);
428             sub Latin6::length(;$);
429             sub Latin6::substr($$;$$);
430             sub Latin6::index($$;$);
431             sub Latin6::rindex($$;$);
432             sub Latin6::escape(;$);
433              
434             #
435             # Regexp work
436             #
437 200     200   16986 BEGIN { CORE::eval q{ use vars qw(
  200     200   1667  
  200         382  
  200         85581  
438             $Latin6::re_a
439             $Latin6::re_t
440             $Latin6::re_n
441             $Latin6::re_r
442             ) } }
443              
444             #
445             # Character class
446             #
447 200     200   17678 BEGIN { CORE::eval q{ use vars qw(
  200     200   1231  
  200         371  
  200         3204822  
448             $dot
449             $dot_s
450             $eD
451             $eS
452             $eW
453             $eH
454             $eV
455             $eR
456             $eN
457             $not_alnum
458             $not_alpha
459             $not_ascii
460             $not_blank
461             $not_cntrl
462             $not_digit
463             $not_graph
464             $not_lower
465             $not_lower_i
466             $not_print
467             $not_punct
468             $not_space
469             $not_upper
470             $not_upper_i
471             $not_word
472             $not_xdigit
473             $eb
474             $eB
475             ) } }
476              
477             ${Elatin6::dot} = qr{(?>[^\x0A])};
478             ${Elatin6::dot_s} = qr{(?>[\x00-\xFF])};
479             ${Elatin6::eD} = qr{(?>[^0-9])};
480              
481             # Vertical tabs are now whitespace
482             # \s in a regex now matches a vertical tab in all circumstances.
483             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
484             # ${Elatin6::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
485             # ${Elatin6::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
486             ${Elatin6::eS} = qr{(?>[^\s])};
487              
488             ${Elatin6::eW} = qr{(?>[^0-9A-Z_a-z])};
489             ${Elatin6::eH} = qr{(?>[^\x09\x20])};
490             ${Elatin6::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
491             ${Elatin6::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
492             ${Elatin6::eN} = qr{(?>[^\x0A])};
493             ${Elatin6::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
494             ${Elatin6::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
495             ${Elatin6::not_ascii} = qr{(?>[^\x00-\x7F])};
496             ${Elatin6::not_blank} = qr{(?>[^\x09\x20])};
497             ${Elatin6::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
498             ${Elatin6::not_digit} = qr{(?>[^\x30-\x39])};
499             ${Elatin6::not_graph} = qr{(?>[^\x21-\x7F])};
500             ${Elatin6::not_lower} = qr{(?>[^\x61-\x7A])};
501             ${Elatin6::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
502             # ${Elatin6::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
503             ${Elatin6::not_print} = qr{(?>[^\x20-\x7F])};
504             ${Elatin6::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
505             ${Elatin6::not_space} = qr{(?>[^\s\x0B])};
506             ${Elatin6::not_upper} = qr{(?>[^\x41-\x5A])};
507             ${Elatin6::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
508             # ${Elatin6::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
509             ${Elatin6::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
510             ${Elatin6::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
511             ${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))};
512             ${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]))};
513              
514             # avoid: Name "Elatin6::foo" used only once: possible typo at here.
515             ${Elatin6::dot} = ${Elatin6::dot};
516             ${Elatin6::dot_s} = ${Elatin6::dot_s};
517             ${Elatin6::eD} = ${Elatin6::eD};
518             ${Elatin6::eS} = ${Elatin6::eS};
519             ${Elatin6::eW} = ${Elatin6::eW};
520             ${Elatin6::eH} = ${Elatin6::eH};
521             ${Elatin6::eV} = ${Elatin6::eV};
522             ${Elatin6::eR} = ${Elatin6::eR};
523             ${Elatin6::eN} = ${Elatin6::eN};
524             ${Elatin6::not_alnum} = ${Elatin6::not_alnum};
525             ${Elatin6::not_alpha} = ${Elatin6::not_alpha};
526             ${Elatin6::not_ascii} = ${Elatin6::not_ascii};
527             ${Elatin6::not_blank} = ${Elatin6::not_blank};
528             ${Elatin6::not_cntrl} = ${Elatin6::not_cntrl};
529             ${Elatin6::not_digit} = ${Elatin6::not_digit};
530             ${Elatin6::not_graph} = ${Elatin6::not_graph};
531             ${Elatin6::not_lower} = ${Elatin6::not_lower};
532             ${Elatin6::not_lower_i} = ${Elatin6::not_lower_i};
533             ${Elatin6::not_print} = ${Elatin6::not_print};
534             ${Elatin6::not_punct} = ${Elatin6::not_punct};
535             ${Elatin6::not_space} = ${Elatin6::not_space};
536             ${Elatin6::not_upper} = ${Elatin6::not_upper};
537             ${Elatin6::not_upper_i} = ${Elatin6::not_upper_i};
538             ${Elatin6::not_word} = ${Elatin6::not_word};
539             ${Elatin6::not_xdigit} = ${Elatin6::not_xdigit};
540             ${Elatin6::eb} = ${Elatin6::eb};
541             ${Elatin6::eB} = ${Elatin6::eB};
542              
543             #
544             # Latin-6 split
545             #
546             sub Elatin6::split(;$$$) {
547              
548             # P.794 29.2.161. split
549             # in Chapter 29: Functions
550             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
551              
552             # P.951 split
553             # in Chapter 27: Functions
554             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
555              
556 0     0 0 0 my $pattern = $_[0];
557 0         0 my $string = $_[1];
558 0         0 my $limit = $_[2];
559              
560             # if $pattern is also omitted or is the literal space, " "
561 0 0       0 if (not defined $pattern) {
562 0         0 $pattern = ' ';
563             }
564              
565             # if $string is omitted, the function splits the $_ string
566 0 0       0 if (not defined $string) {
567 0 0       0 if (defined $_) {
568 0         0 $string = $_;
569             }
570             else {
571 0         0 $string = '';
572             }
573             }
574              
575 0         0 my @split = ();
576              
577             # when string is empty
578 0 0       0 if ($string eq '') {
    0          
579              
580             # resulting list value in list context
581 0 0       0 if (wantarray) {
582 0         0 return @split;
583             }
584              
585             # count of substrings in scalar context
586             else {
587 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
588 0         0 @_ = @split;
589 0         0 return scalar @_;
590             }
591             }
592              
593             # split's first argument is more consistently interpreted
594             #
595             # After some changes earlier in v5.17, split's behavior has been simplified:
596             # if the PATTERN argument evaluates to a string containing one space, it is
597             # treated the way that a literal string containing one space once was.
598             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
599              
600             # if $pattern is also omitted or is the literal space, " ", the function splits
601             # on whitespace, /\s+/, after skipping any leading whitespace
602             # (and so on)
603              
604             elsif ($pattern eq ' ') {
605 0 0       0 if (not defined $limit) {
606 0         0 return CORE::split(' ', $string);
607             }
608             else {
609 0         0 return CORE::split(' ', $string, $limit);
610             }
611             }
612              
613             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
614 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
615              
616             # a pattern capable of matching either the null string or something longer than the
617             # null string will split the value of $string into separate characters wherever it
618             # matches the null string between characters
619             # (and so on)
620              
621 0 0       0 if ('' =~ / \A $pattern \z /xms) {
622 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
623 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
624              
625             # P.1024 Appendix W.10 Multibyte Processing
626             # of ISBN 1-56592-224-7 CJKV Information Processing
627             # (and so on)
628              
629             # the //m modifier is assumed when you split on the pattern /^/
630             # (and so on)
631              
632             # V
633 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
634              
635             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
636             # is included in the resulting list, interspersed with the fields that are ordinarily returned
637             # (and so on)
638              
639 0         0 local $@;
640 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
641 0         0 push @split, CORE::eval('$' . $digit);
642             }
643             }
644             }
645              
646             else {
647 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
648              
649             # V
650 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
651 0         0 local $@;
652 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
653 0         0 push @split, CORE::eval('$' . $digit);
654             }
655             }
656             }
657             }
658              
659             elsif ($limit > 0) {
660 0 0       0 if ('' =~ / \A $pattern \z /xms) {
661 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
662 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
663              
664             # V
665 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
666 0         0 local $@;
667 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
668 0         0 push @split, CORE::eval('$' . $digit);
669             }
670             }
671             }
672             }
673             else {
674 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
675 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
676              
677             # V
678 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
679 0         0 local $@;
680 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
681 0         0 push @split, CORE::eval('$' . $digit);
682             }
683             }
684             }
685             }
686             }
687              
688 0 0       0 if (CORE::length($string) > 0) {
689 0         0 push @split, $string;
690             }
691              
692             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
693 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
694 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
695 0         0 pop @split;
696             }
697             }
698              
699             # resulting list value in list context
700 0 0       0 if (wantarray) {
701 0         0 return @split;
702             }
703              
704             # count of substrings in scalar context
705             else {
706 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
707 0         0 @_ = @split;
708 0         0 return scalar @_;
709             }
710             }
711              
712             #
713             # get last subexpression offsets
714             #
715             sub _last_subexpression_offsets {
716 0     0   0 my $pattern = $_[0];
717              
718             # remove comment
719 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
720              
721 0         0 my $modifier = '';
722 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
723 0         0 $modifier = $1;
724 0         0 $modifier =~ s/-[A-Za-z]*//;
725             }
726              
727             # with /x modifier
728 0         0 my @char = ();
729 0 0       0 if ($modifier =~ /x/oxms) {
730 0         0 @char = $pattern =~ /\G((?>
731             [^\\\#\[\(] |
732             \\ $q_char |
733             \# (?>[^\n]*) $ |
734             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
735             \(\? |
736             $q_char
737             ))/oxmsg;
738             }
739              
740             # without /x modifier
741             else {
742 0         0 @char = $pattern =~ /\G((?>
743             [^\\\[\(] |
744             \\ $q_char |
745             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
746             \(\? |
747             $q_char
748             ))/oxmsg;
749             }
750              
751 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
752             }
753              
754             #
755             # Latin-6 transliteration (tr///)
756             #
757             sub Elatin6::tr($$$$;$) {
758              
759 0     0 0 0 my $bind_operator = $_[1];
760 0         0 my $searchlist = $_[2];
761 0         0 my $replacementlist = $_[3];
762 0   0     0 my $modifier = $_[4] || '';
763              
764 0 0       0 if ($modifier =~ /r/oxms) {
765 0 0       0 if ($bind_operator =~ / !~ /oxms) {
766 0         0 croak "Using !~ with tr///r doesn't make sense";
767             }
768             }
769              
770 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
771 0         0 my @searchlist = _charlist_tr($searchlist);
772 0         0 my @replacementlist = _charlist_tr($replacementlist);
773              
774 0         0 my %tr = ();
775 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
776 0 0       0 if (not exists $tr{$searchlist[$i]}) {
777 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
778 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
779             }
780             elsif ($modifier =~ /d/oxms) {
781 0         0 $tr{$searchlist[$i]} = '';
782             }
783             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
784 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
785             }
786             else {
787 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
788             }
789             }
790             }
791              
792 0         0 my $tr = 0;
793 0         0 my $replaced = '';
794 0 0       0 if ($modifier =~ /c/oxms) {
795 0         0 while (defined(my $char = shift @char)) {
796 0 0       0 if (not exists $tr{$char}) {
797 0 0       0 if (defined $replacementlist[0]) {
798 0         0 $replaced .= $replacementlist[0];
799             }
800 0         0 $tr++;
801 0 0       0 if ($modifier =~ /s/oxms) {
802 0   0     0 while (@char and (not exists $tr{$char[0]})) {
803 0         0 shift @char;
804 0         0 $tr++;
805             }
806             }
807             }
808             else {
809 0         0 $replaced .= $char;
810             }
811             }
812             }
813             else {
814 0         0 while (defined(my $char = shift @char)) {
815 0 0       0 if (exists $tr{$char}) {
816 0         0 $replaced .= $tr{$char};
817 0         0 $tr++;
818 0 0       0 if ($modifier =~ /s/oxms) {
819 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
820 0         0 shift @char;
821 0         0 $tr++;
822             }
823             }
824             }
825             else {
826 0         0 $replaced .= $char;
827             }
828             }
829             }
830              
831 0 0       0 if ($modifier =~ /r/oxms) {
832 0         0 return $replaced;
833             }
834             else {
835 0         0 $_[0] = $replaced;
836 0 0       0 if ($bind_operator =~ / !~ /oxms) {
837 0         0 return not $tr;
838             }
839             else {
840 0         0 return $tr;
841             }
842             }
843             }
844              
845             #
846             # Latin-6 chop
847             #
848             sub Elatin6::chop(@) {
849              
850 0     0 0 0 my $chop;
851 0 0       0 if (@_ == 0) {
852 0         0 my @char = /\G (?>$q_char) /oxmsg;
853 0         0 $chop = pop @char;
854 0         0 $_ = join '', @char;
855             }
856             else {
857 0         0 for (@_) {
858 0         0 my @char = /\G (?>$q_char) /oxmsg;
859 0         0 $chop = pop @char;
860 0         0 $_ = join '', @char;
861             }
862             }
863 0         0 return $chop;
864             }
865              
866             #
867             # Latin-6 index by octet
868             #
869             sub Elatin6::index($$;$) {
870              
871 0     0 1 0 my($str,$substr,$position) = @_;
872 0   0     0 $position ||= 0;
873 0         0 my $pos = 0;
874              
875 0         0 while ($pos < CORE::length($str)) {
876 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
877 0 0       0 if ($pos >= $position) {
878 0         0 return $pos;
879             }
880             }
881 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
882 0         0 $pos += CORE::length($1);
883             }
884             else {
885 0         0 $pos += 1;
886             }
887             }
888 0         0 return -1;
889             }
890              
891             #
892             # Latin-6 reverse index
893             #
894             sub Elatin6::rindex($$;$) {
895              
896 0     0 0 0 my($str,$substr,$position) = @_;
897 0   0     0 $position ||= CORE::length($str) - 1;
898 0         0 my $pos = 0;
899 0         0 my $rindex = -1;
900              
901 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
902 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
903 0         0 $rindex = $pos;
904             }
905 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
906 0         0 $pos += CORE::length($1);
907             }
908             else {
909 0         0 $pos += 1;
910             }
911             }
912 0         0 return $rindex;
913             }
914              
915             #
916             # Latin-6 lower case first with parameter
917             #
918             sub Elatin6::lcfirst(@) {
919 0 0   0 0 0 if (@_) {
920 0         0 my $s = shift @_;
921 0 0 0     0 if (@_ and wantarray) {
922 0         0 return Elatin6::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
923             }
924             else {
925 0         0 return Elatin6::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
926             }
927             }
928             else {
929 0         0 return Elatin6::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
930             }
931             }
932              
933             #
934             # Latin-6 lower case first without parameter
935             #
936             sub Elatin6::lcfirst_() {
937 0     0 0 0 return Elatin6::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
938             }
939              
940             #
941             # Latin-6 lower case with parameter
942             #
943             sub Elatin6::lc(@) {
944 0 0   0 0 0 if (@_) {
945 0         0 my $s = shift @_;
946 0 0 0     0 if (@_ and wantarray) {
947 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
948             }
949             else {
950 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
951             }
952             }
953             else {
954 0         0 return Elatin6::lc_();
955             }
956             }
957              
958             #
959             # Latin-6 lower case without parameter
960             #
961             sub Elatin6::lc_() {
962 0     0 0 0 my $s = $_;
963 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
964             }
965              
966             #
967             # Latin-6 upper case first with parameter
968             #
969             sub Elatin6::ucfirst(@) {
970 0 0   0 0 0 if (@_) {
971 0         0 my $s = shift @_;
972 0 0 0     0 if (@_ and wantarray) {
973 0         0 return Elatin6::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
974             }
975             else {
976 0         0 return Elatin6::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
977             }
978             }
979             else {
980 0         0 return Elatin6::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
981             }
982             }
983              
984             #
985             # Latin-6 upper case first without parameter
986             #
987             sub Elatin6::ucfirst_() {
988 0     0 0 0 return Elatin6::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
989             }
990              
991             #
992             # Latin-6 upper case with parameter
993             #
994             sub Elatin6::uc(@) {
995 0 0   0 0 0 if (@_) {
996 0         0 my $s = shift @_;
997 0 0 0     0 if (@_ and wantarray) {
998 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
999             }
1000             else {
1001 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1002             }
1003             }
1004             else {
1005 0         0 return Elatin6::uc_();
1006             }
1007             }
1008              
1009             #
1010             # Latin-6 upper case without parameter
1011             #
1012             sub Elatin6::uc_() {
1013 0     0 0 0 my $s = $_;
1014 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1015             }
1016              
1017             #
1018             # Latin-6 fold case with parameter
1019             #
1020             sub Elatin6::fc(@) {
1021 0 0   0 0 0 if (@_) {
1022 0         0 my $s = shift @_;
1023 0 0 0     0 if (@_ and wantarray) {
1024 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1025             }
1026             else {
1027 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1028             }
1029             }
1030             else {
1031 0         0 return Elatin6::fc_();
1032             }
1033             }
1034              
1035             #
1036             # Latin-6 fold case without parameter
1037             #
1038             sub Elatin6::fc_() {
1039 0     0 0 0 my $s = $_;
1040 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1041             }
1042              
1043             #
1044             # Latin-6 regexp capture
1045             #
1046             {
1047             sub Elatin6::capture {
1048 0     0 1 0 return $_[0];
1049             }
1050             }
1051              
1052             #
1053             # Latin-6 regexp ignore case modifier
1054             #
1055             sub Elatin6::ignorecase {
1056              
1057 0     0 0 0 my @string = @_;
1058 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1059              
1060             # ignore case of $scalar or @array
1061 0         0 for my $string (@string) {
1062              
1063             # split regexp
1064 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1065              
1066             # unescape character
1067 0         0 for (my $i=0; $i <= $#char; $i++) {
1068 0 0       0 next if not defined $char[$i];
1069              
1070             # open character class [...]
1071 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1072 0         0 my $left = $i;
1073              
1074             # [] make die "unmatched [] in regexp ...\n"
1075              
1076 0 0       0 if ($char[$i+1] eq ']') {
1077 0         0 $i++;
1078             }
1079              
1080 0         0 while (1) {
1081 0 0       0 if (++$i > $#char) {
1082 0         0 croak "Unmatched [] in regexp";
1083             }
1084 0 0       0 if ($char[$i] eq ']') {
1085 0         0 my $right = $i;
1086 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1087              
1088             # escape character
1089 0         0 for my $char (@charlist) {
1090 0 0       0 if (0) {
1091             }
1092              
1093 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1094 0         0 $char = '\\' . $char;
1095             }
1096             }
1097              
1098             # [...]
1099 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1100              
1101 0         0 $i = $left;
1102 0         0 last;
1103             }
1104             }
1105             }
1106              
1107             # open character class [^...]
1108             elsif ($char[$i] eq '[^') {
1109 0         0 my $left = $i;
1110              
1111             # [^] make die "unmatched [] in regexp ...\n"
1112              
1113 0 0       0 if ($char[$i+1] eq ']') {
1114 0         0 $i++;
1115             }
1116              
1117 0         0 while (1) {
1118 0 0       0 if (++$i > $#char) {
1119 0         0 croak "Unmatched [] in regexp";
1120             }
1121 0 0       0 if ($char[$i] eq ']') {
1122 0         0 my $right = $i;
1123 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1124              
1125             # escape character
1126 0         0 for my $char (@charlist) {
1127 0 0       0 if (0) {
1128             }
1129              
1130 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1131 0         0 $char = '\\' . $char;
1132             }
1133             }
1134              
1135             # [^...]
1136 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1137              
1138 0         0 $i = $left;
1139 0         0 last;
1140             }
1141             }
1142             }
1143              
1144             # rewrite classic character class or escape character
1145             elsif (my $char = classic_character_class($char[$i])) {
1146 0         0 $char[$i] = $char;
1147             }
1148              
1149             # with /i modifier
1150             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1151 0         0 my $uc = Elatin6::uc($char[$i]);
1152 0         0 my $fc = Elatin6::fc($char[$i]);
1153 0 0       0 if ($uc ne $fc) {
1154 0 0       0 if (CORE::length($fc) == 1) {
1155 0         0 $char[$i] = '[' . $uc . $fc . ']';
1156             }
1157             else {
1158 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1159             }
1160             }
1161             }
1162             }
1163              
1164             # characterize
1165 0         0 for (my $i=0; $i <= $#char; $i++) {
1166 0 0       0 next if not defined $char[$i];
1167              
1168 0 0       0 if (0) {
1169             }
1170              
1171             # quote character before ? + * {
1172 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1173 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1174 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1175             }
1176             }
1177             }
1178              
1179 0         0 $string = join '', @char;
1180             }
1181              
1182             # make regexp string
1183 0         0 return @string;
1184             }
1185              
1186             #
1187             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1188             #
1189             sub Elatin6::classic_character_class {
1190 0     0 0 0 my($char) = @_;
1191              
1192             return {
1193 0   0     0 '\D' => '${Elatin6::eD}',
1194             '\S' => '${Elatin6::eS}',
1195             '\W' => '${Elatin6::eW}',
1196             '\d' => '[0-9]',
1197              
1198             # Before Perl 5.6, \s only matched the five whitespace characters
1199             # tab, newline, form-feed, carriage return, and the space character
1200             # itself, which, taken together, is the character class [\t\n\f\r ].
1201              
1202             # Vertical tabs are now whitespace
1203             # \s in a regex now matches a vertical tab in all circumstances.
1204             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1205             # \t \n \v \f \r space
1206             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1207             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1208             '\s' => '\s',
1209              
1210             '\w' => '[0-9A-Z_a-z]',
1211             '\C' => '[\x00-\xFF]',
1212             '\X' => 'X',
1213              
1214             # \h \v \H \V
1215              
1216             # P.114 Character Class Shortcuts
1217             # in Chapter 7: In the World of Regular Expressions
1218             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1219              
1220             # P.357 13.2.3 Whitespace
1221             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1222             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1223             #
1224             # 0x00009 CHARACTER TABULATION h s
1225             # 0x0000a LINE FEED (LF) vs
1226             # 0x0000b LINE TABULATION v
1227             # 0x0000c FORM FEED (FF) vs
1228             # 0x0000d CARRIAGE RETURN (CR) vs
1229             # 0x00020 SPACE h s
1230              
1231             # P.196 Table 5-9. Alphanumeric regex metasymbols
1232             # in Chapter 5. Pattern Matching
1233             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1234              
1235             # (and so on)
1236              
1237             '\H' => '${Elatin6::eH}',
1238             '\V' => '${Elatin6::eV}',
1239             '\h' => '[\x09\x20]',
1240             '\v' => '[\x0A\x0B\x0C\x0D]',
1241             '\R' => '${Elatin6::eR}',
1242              
1243             # \N
1244             #
1245             # http://perldoc.perl.org/perlre.html
1246             # Character Classes and other Special Escapes
1247             # Any character but \n (experimental). Not affected by /s modifier
1248              
1249             '\N' => '${Elatin6::eN}',
1250              
1251             # \b \B
1252              
1253             # P.180 Boundaries: The \b and \B Assertions
1254             # in Chapter 5: Pattern Matching
1255             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1256              
1257             # P.219 Boundaries: The \b and \B Assertions
1258             # in Chapter 5: Pattern Matching
1259             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1260              
1261             # \b really means (?:(?<=\w)(?!\w)|(?
1262             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1263             '\b' => '${Elatin6::eb}',
1264              
1265             # \B really means (?:(?<=\w)(?=\w)|(?
1266             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1267             '\B' => '${Elatin6::eB}',
1268              
1269             }->{$char} || '';
1270             }
1271              
1272             #
1273             # prepare Latin-6 characters per length
1274             #
1275              
1276             # 1 octet characters
1277             my @chars1 = ();
1278             sub chars1 {
1279 0 0   0 0 0 if (@chars1) {
1280 0         0 return @chars1;
1281             }
1282 0 0       0 if (exists $range_tr{1}) {
1283 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1284 0         0 while (my @range = splice(@ranges,0,1)) {
1285 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1286 0         0 push @chars1, pack 'C', $oct0;
1287             }
1288             }
1289             }
1290 0         0 return @chars1;
1291             }
1292              
1293             # 2 octets characters
1294             my @chars2 = ();
1295             sub chars2 {
1296 0 0   0 0 0 if (@chars2) {
1297 0         0 return @chars2;
1298             }
1299 0 0       0 if (exists $range_tr{2}) {
1300 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1301 0         0 while (my @range = splice(@ranges,0,2)) {
1302 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1303 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1304 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1305             }
1306             }
1307             }
1308             }
1309 0         0 return @chars2;
1310             }
1311              
1312             # 3 octets characters
1313             my @chars3 = ();
1314             sub chars3 {
1315 0 0   0 0 0 if (@chars3) {
1316 0         0 return @chars3;
1317             }
1318 0 0       0 if (exists $range_tr{3}) {
1319 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1320 0         0 while (my @range = splice(@ranges,0,3)) {
1321 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1322 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1323 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1324 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1325             }
1326             }
1327             }
1328             }
1329             }
1330 0         0 return @chars3;
1331             }
1332              
1333             # 4 octets characters
1334             my @chars4 = ();
1335             sub chars4 {
1336 0 0   0 0 0 if (@chars4) {
1337 0         0 return @chars4;
1338             }
1339 0 0       0 if (exists $range_tr{4}) {
1340 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1341 0         0 while (my @range = splice(@ranges,0,4)) {
1342 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1343 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1344 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1345 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1346 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1347             }
1348             }
1349             }
1350             }
1351             }
1352             }
1353 0         0 return @chars4;
1354             }
1355              
1356             #
1357             # Latin-6 open character list for tr
1358             #
1359             sub _charlist_tr {
1360              
1361 0     0   0 local $_ = shift @_;
1362              
1363             # unescape character
1364 0         0 my @char = ();
1365 0         0 while (not /\G \z/oxmsgc) {
1366 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1367 0         0 push @char, '\-';
1368             }
1369             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1370 0         0 push @char, CORE::chr(oct $1);
1371             }
1372             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1373 0         0 push @char, CORE::chr(hex $1);
1374             }
1375             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1376 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1377             }
1378             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1379 0         0 push @char, {
1380             '\0' => "\0",
1381             '\n' => "\n",
1382             '\r' => "\r",
1383             '\t' => "\t",
1384             '\f' => "\f",
1385             '\b' => "\x08", # \b means backspace in character class
1386             '\a' => "\a",
1387             '\e' => "\e",
1388             }->{$1};
1389             }
1390             elsif (/\G \\ ($q_char) /oxmsgc) {
1391 0         0 push @char, $1;
1392             }
1393             elsif (/\G ($q_char) /oxmsgc) {
1394 0         0 push @char, $1;
1395             }
1396             }
1397              
1398             # join separated multiple-octet
1399 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1400              
1401             # unescape '-'
1402 0         0 my @i = ();
1403 0         0 for my $i (0 .. $#char) {
1404 0 0       0 if ($char[$i] eq '\-') {
    0          
1405 0         0 $char[$i] = '-';
1406             }
1407             elsif ($char[$i] eq '-') {
1408 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1409 0         0 push @i, $i;
1410             }
1411             }
1412             }
1413              
1414             # open character list (reverse for splice)
1415 0         0 for my $i (CORE::reverse @i) {
1416 0         0 my @range = ();
1417              
1418             # range error
1419 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1420 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1421             }
1422              
1423             # range of multiple-octet code
1424 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1425 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1426 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1427             }
1428             elsif (CORE::length($char[$i+1]) == 2) {
1429 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1430 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1431             }
1432             elsif (CORE::length($char[$i+1]) == 3) {
1433 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1434 0         0 push @range, chars2();
1435 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1436             }
1437             elsif (CORE::length($char[$i+1]) == 4) {
1438 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1439 0         0 push @range, chars2();
1440 0         0 push @range, chars3();
1441 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1442             }
1443             else {
1444 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1445             }
1446             }
1447             elsif (CORE::length($char[$i-1]) == 2) {
1448 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1449 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1450             }
1451             elsif (CORE::length($char[$i+1]) == 3) {
1452 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1453 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1454             }
1455             elsif (CORE::length($char[$i+1]) == 4) {
1456 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1457 0         0 push @range, chars3();
1458 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1459             }
1460             else {
1461 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1462             }
1463             }
1464             elsif (CORE::length($char[$i-1]) == 3) {
1465 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1466 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1467             }
1468             elsif (CORE::length($char[$i+1]) == 4) {
1469 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1470 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1471             }
1472             else {
1473 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1474             }
1475             }
1476             elsif (CORE::length($char[$i-1]) == 4) {
1477 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1478 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1479             }
1480             else {
1481 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1482             }
1483             }
1484             else {
1485 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1486             }
1487              
1488 0         0 splice @char, $i-1, 3, @range;
1489             }
1490              
1491 0         0 return @char;
1492             }
1493              
1494             #
1495             # Latin-6 open character class
1496             #
1497             sub _cc {
1498 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1499 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1500             }
1501             elsif (scalar(@_) == 1) {
1502 0         0 return sprintf('\x%02X',$_[0]);
1503             }
1504             elsif (scalar(@_) == 2) {
1505 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1506 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1507             }
1508             elsif ($_[0] == $_[1]) {
1509 0         0 return sprintf('\x%02X',$_[0]);
1510             }
1511             elsif (($_[0]+1) == $_[1]) {
1512 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1513             }
1514             else {
1515 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1516             }
1517             }
1518             else {
1519 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1520             }
1521             }
1522              
1523             #
1524             # Latin-6 octet range
1525             #
1526             sub _octets {
1527 0     0   0 my $length = shift @_;
1528              
1529 0 0       0 if ($length == 1) {
1530 0         0 my($a1) = unpack 'C', $_[0];
1531 0         0 my($z1) = unpack 'C', $_[1];
1532              
1533 0 0       0 if ($a1 > $z1) {
1534 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1535             }
1536              
1537 0 0       0 if ($a1 == $z1) {
    0          
1538 0         0 return sprintf('\x%02X',$a1);
1539             }
1540             elsif (($a1+1) == $z1) {
1541 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1542             }
1543             else {
1544 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1545             }
1546             }
1547             else {
1548 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1549             }
1550             }
1551              
1552             #
1553             # Latin-6 range regexp
1554             #
1555             sub _range_regexp {
1556 0     0   0 my($length,$first,$last) = @_;
1557              
1558 0         0 my @range_regexp = ();
1559 0 0       0 if (not exists $range_tr{$length}) {
1560 0         0 return @range_regexp;
1561             }
1562              
1563 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1564 0         0 while (my @range = splice(@ranges,0,$length)) {
1565 0         0 my $min = '';
1566 0         0 my $max = '';
1567 0         0 for (my $i=0; $i < $length; $i++) {
1568 0         0 $min .= pack 'C', $range[$i][0];
1569 0         0 $max .= pack 'C', $range[$i][-1];
1570             }
1571              
1572             # min___max
1573             # FIRST_____________LAST
1574             # (nothing)
1575              
1576 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1577             }
1578              
1579             # **********
1580             # min_________max
1581             # FIRST_____________LAST
1582             # **********
1583              
1584             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1585 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1586             }
1587              
1588             # **********************
1589             # min________________max
1590             # FIRST_____________LAST
1591             # **********************
1592              
1593             elsif (($min eq $first) and ($max eq $last)) {
1594 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1595             }
1596              
1597             # *********
1598             # min___max
1599             # FIRST_____________LAST
1600             # *********
1601              
1602             elsif (($first le $min) and ($max le $last)) {
1603 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1604             }
1605              
1606             # **********************
1607             # min__________________________max
1608             # FIRST_____________LAST
1609             # **********************
1610              
1611             elsif (($min le $first) and ($last le $max)) {
1612 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1613             }
1614              
1615             # *********
1616             # min________max
1617             # FIRST_____________LAST
1618             # *********
1619              
1620             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1621 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1622             }
1623              
1624             # min___max
1625             # FIRST_____________LAST
1626             # (nothing)
1627              
1628             elsif ($last lt $min) {
1629             }
1630              
1631             else {
1632 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1633             }
1634             }
1635              
1636 0         0 return @range_regexp;
1637             }
1638              
1639             #
1640             # Latin-6 open character list for qr and not qr
1641             #
1642             sub _charlist {
1643              
1644 0     0   0 my $modifier = pop @_;
1645 0         0 my @char = @_;
1646              
1647 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1648              
1649             # unescape character
1650 0         0 for (my $i=0; $i <= $#char; $i++) {
1651              
1652             # escape - to ...
1653 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1654 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1655 0         0 $char[$i] = '...';
1656             }
1657             }
1658              
1659             # octal escape sequence
1660             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1661 0         0 $char[$i] = octchr($1);
1662             }
1663              
1664             # hexadecimal escape sequence
1665             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1666 0         0 $char[$i] = hexchr($1);
1667             }
1668              
1669             # \b{...} --> b\{...}
1670             # \B{...} --> B\{...}
1671             # \N{CHARNAME} --> N\{CHARNAME}
1672             # \p{PROPERTY} --> p\{PROPERTY}
1673             # \P{PROPERTY} --> P\{PROPERTY}
1674             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1675 0         0 $char[$i] = $1 . '\\' . $2;
1676             }
1677              
1678             # \p, \P, \X --> p, P, X
1679             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1680 0         0 $char[$i] = $1;
1681             }
1682              
1683             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1684 0         0 $char[$i] = CORE::chr oct $1;
1685             }
1686             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1687 0         0 $char[$i] = CORE::chr hex $1;
1688             }
1689             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1690 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1691             }
1692             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1693 0         0 $char[$i] = {
1694             '\0' => "\0",
1695             '\n' => "\n",
1696             '\r' => "\r",
1697             '\t' => "\t",
1698             '\f' => "\f",
1699             '\b' => "\x08", # \b means backspace in character class
1700             '\a' => "\a",
1701             '\e' => "\e",
1702             '\d' => '[0-9]',
1703              
1704             # Vertical tabs are now whitespace
1705             # \s in a regex now matches a vertical tab in all circumstances.
1706             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1707             # \t \n \v \f \r space
1708             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1709             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1710             '\s' => '\s',
1711              
1712             '\w' => '[0-9A-Z_a-z]',
1713             '\D' => '${Elatin6::eD}',
1714             '\S' => '${Elatin6::eS}',
1715             '\W' => '${Elatin6::eW}',
1716              
1717             '\H' => '${Elatin6::eH}',
1718             '\V' => '${Elatin6::eV}',
1719             '\h' => '[\x09\x20]',
1720             '\v' => '[\x0A\x0B\x0C\x0D]',
1721             '\R' => '${Elatin6::eR}',
1722              
1723             }->{$1};
1724             }
1725              
1726             # POSIX-style character classes
1727             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1728 0         0 $char[$i] = {
1729              
1730             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1731             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1732             '[:^lower:]' => '${Elatin6::not_lower_i}',
1733             '[:^upper:]' => '${Elatin6::not_upper_i}',
1734              
1735             }->{$1};
1736             }
1737             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1738 0         0 $char[$i] = {
1739              
1740             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1741             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1742             '[:ascii:]' => '[\x00-\x7F]',
1743             '[:blank:]' => '[\x09\x20]',
1744             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1745             '[:digit:]' => '[\x30-\x39]',
1746             '[:graph:]' => '[\x21-\x7F]',
1747             '[:lower:]' => '[\x61-\x7A]',
1748             '[:print:]' => '[\x20-\x7F]',
1749             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1750              
1751             # P.174 POSIX-Style Character Classes
1752             # in Chapter 5: Pattern Matching
1753             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1754              
1755             # P.311 11.2.4 Character Classes and other Special Escapes
1756             # in Chapter 11: perlre: Perl regular expressions
1757             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1758              
1759             # P.210 POSIX-Style Character Classes
1760             # in Chapter 5: Pattern Matching
1761             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1762              
1763             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1764              
1765             '[:upper:]' => '[\x41-\x5A]',
1766             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1767             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1768             '[:^alnum:]' => '${Elatin6::not_alnum}',
1769             '[:^alpha:]' => '${Elatin6::not_alpha}',
1770             '[:^ascii:]' => '${Elatin6::not_ascii}',
1771             '[:^blank:]' => '${Elatin6::not_blank}',
1772             '[:^cntrl:]' => '${Elatin6::not_cntrl}',
1773             '[:^digit:]' => '${Elatin6::not_digit}',
1774             '[:^graph:]' => '${Elatin6::not_graph}',
1775             '[:^lower:]' => '${Elatin6::not_lower}',
1776             '[:^print:]' => '${Elatin6::not_print}',
1777             '[:^punct:]' => '${Elatin6::not_punct}',
1778             '[:^space:]' => '${Elatin6::not_space}',
1779             '[:^upper:]' => '${Elatin6::not_upper}',
1780             '[:^word:]' => '${Elatin6::not_word}',
1781             '[:^xdigit:]' => '${Elatin6::not_xdigit}',
1782              
1783             }->{$1};
1784             }
1785             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1786 0         0 $char[$i] = $1;
1787             }
1788             }
1789              
1790             # open character list
1791 0         0 my @singleoctet = ();
1792 0         0 my @multipleoctet = ();
1793 0         0 for (my $i=0; $i <= $#char; ) {
1794              
1795             # escaped -
1796 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1797 0         0 $i += 1;
1798 0         0 next;
1799             }
1800              
1801             # make range regexp
1802             elsif ($char[$i] eq '...') {
1803              
1804             # range error
1805 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1806 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1807             }
1808             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1809 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1810 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1811             }
1812             }
1813              
1814             # make range regexp per length
1815 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1816 0         0 my @regexp = ();
1817              
1818             # is first and last
1819 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1820 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1821             }
1822              
1823             # is first
1824             elsif ($length == CORE::length($char[$i-1])) {
1825 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1826             }
1827              
1828             # is inside in first and last
1829             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1830 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1831             }
1832              
1833             # is last
1834             elsif ($length == CORE::length($char[$i+1])) {
1835 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1836             }
1837              
1838             else {
1839 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1840             }
1841              
1842 0 0       0 if ($length == 1) {
1843 0         0 push @singleoctet, @regexp;
1844             }
1845             else {
1846 0         0 push @multipleoctet, @regexp;
1847             }
1848             }
1849              
1850 0         0 $i += 2;
1851             }
1852              
1853             # with /i modifier
1854             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1855 0 0       0 if ($modifier =~ /i/oxms) {
1856 0         0 my $uc = Elatin6::uc($char[$i]);
1857 0         0 my $fc = Elatin6::fc($char[$i]);
1858 0 0       0 if ($uc ne $fc) {
1859 0 0       0 if (CORE::length($fc) == 1) {
1860 0         0 push @singleoctet, $uc, $fc;
1861             }
1862             else {
1863 0         0 push @singleoctet, $uc;
1864 0         0 push @multipleoctet, $fc;
1865             }
1866             }
1867             else {
1868 0         0 push @singleoctet, $char[$i];
1869             }
1870             }
1871             else {
1872 0         0 push @singleoctet, $char[$i];
1873             }
1874 0         0 $i += 1;
1875             }
1876              
1877             # single character of single octet code
1878             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1879 0         0 push @singleoctet, "\t", "\x20";
1880 0         0 $i += 1;
1881             }
1882             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1883 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1884 0         0 $i += 1;
1885             }
1886             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1887 0         0 push @singleoctet, $char[$i];
1888 0         0 $i += 1;
1889             }
1890              
1891             # single character of multiple-octet code
1892             else {
1893 0         0 push @multipleoctet, $char[$i];
1894 0         0 $i += 1;
1895             }
1896             }
1897              
1898             # quote metachar
1899 0         0 for (@singleoctet) {
1900 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1901 0         0 $_ = '-';
1902             }
1903             elsif (/\A \n \z/oxms) {
1904 0         0 $_ = '\n';
1905             }
1906             elsif (/\A \r \z/oxms) {
1907 0         0 $_ = '\r';
1908             }
1909             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1910 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1911             }
1912             elsif (/\A [\x00-\xFF] \z/oxms) {
1913 0         0 $_ = quotemeta $_;
1914             }
1915             }
1916              
1917             # return character list
1918 0         0 return \@singleoctet, \@multipleoctet;
1919             }
1920              
1921             #
1922             # Latin-6 octal escape sequence
1923             #
1924             sub octchr {
1925 0     0 0 0 my($octdigit) = @_;
1926              
1927 0         0 my @binary = ();
1928 0         0 for my $octal (split(//,$octdigit)) {
1929 0         0 push @binary, {
1930             '0' => '000',
1931             '1' => '001',
1932             '2' => '010',
1933             '3' => '011',
1934             '4' => '100',
1935             '5' => '101',
1936             '6' => '110',
1937             '7' => '111',
1938             }->{$octal};
1939             }
1940 0         0 my $binary = join '', @binary;
1941              
1942 0         0 my $octchr = {
1943             # 1234567
1944             1 => pack('B*', "0000000$binary"),
1945             2 => pack('B*', "000000$binary"),
1946             3 => pack('B*', "00000$binary"),
1947             4 => pack('B*', "0000$binary"),
1948             5 => pack('B*', "000$binary"),
1949             6 => pack('B*', "00$binary"),
1950             7 => pack('B*', "0$binary"),
1951             0 => pack('B*', "$binary"),
1952              
1953             }->{CORE::length($binary) % 8};
1954              
1955 0         0 return $octchr;
1956             }
1957              
1958             #
1959             # Latin-6 hexadecimal escape sequence
1960             #
1961             sub hexchr {
1962 0     0 0 0 my($hexdigit) = @_;
1963              
1964 0         0 my $hexchr = {
1965             1 => pack('H*', "0$hexdigit"),
1966             0 => pack('H*', "$hexdigit"),
1967              
1968             }->{CORE::length($_[0]) % 2};
1969              
1970 0         0 return $hexchr;
1971             }
1972              
1973             #
1974             # Latin-6 open character list for qr
1975             #
1976             sub charlist_qr {
1977              
1978 0     0 0 0 my $modifier = pop @_;
1979 0         0 my @char = @_;
1980              
1981 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1982 0         0 my @singleoctet = @$singleoctet;
1983 0         0 my @multipleoctet = @$multipleoctet;
1984              
1985             # return character list
1986 0 0       0 if (scalar(@singleoctet) >= 1) {
1987              
1988             # with /i modifier
1989 0 0       0 if ($modifier =~ m/i/oxms) {
1990 0         0 my %singleoctet_ignorecase = ();
1991 0         0 for (@singleoctet) {
1992 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1993 0         0 for my $ord (hex($1) .. hex($2)) {
1994 0         0 my $char = CORE::chr($ord);
1995 0         0 my $uc = Elatin6::uc($char);
1996 0         0 my $fc = Elatin6::fc($char);
1997 0 0       0 if ($uc eq $fc) {
1998 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1999             }
2000             else {
2001 0 0       0 if (CORE::length($fc) == 1) {
2002 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2003 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2004             }
2005             else {
2006 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2007 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2008             }
2009             }
2010             }
2011             }
2012 0 0       0 if ($_ ne '') {
2013 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2014             }
2015             }
2016 0         0 my $i = 0;
2017 0         0 my @singleoctet_ignorecase = ();
2018 0         0 for my $ord (0 .. 255) {
2019 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2020 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2021             }
2022             else {
2023 0         0 $i++;
2024             }
2025             }
2026 0         0 @singleoctet = ();
2027 0         0 for my $range (@singleoctet_ignorecase) {
2028 0 0       0 if (ref $range) {
2029 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2030 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2031             }
2032             elsif (scalar(@{$range}) == 2) {
2033 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2034             }
2035             else {
2036 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2037             }
2038             }
2039             }
2040             }
2041              
2042 0         0 my $not_anchor = '';
2043              
2044 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2045             }
2046 0 0       0 if (scalar(@multipleoctet) >= 2) {
2047 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2048             }
2049             else {
2050 0         0 return $multipleoctet[0];
2051             }
2052             }
2053              
2054             #
2055             # Latin-6 open character list for not qr
2056             #
2057             sub charlist_not_qr {
2058              
2059 0     0 0 0 my $modifier = pop @_;
2060 0         0 my @char = @_;
2061              
2062 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2063 0         0 my @singleoctet = @$singleoctet;
2064 0         0 my @multipleoctet = @$multipleoctet;
2065              
2066             # with /i modifier
2067 0 0       0 if ($modifier =~ m/i/oxms) {
2068 0         0 my %singleoctet_ignorecase = ();
2069 0         0 for (@singleoctet) {
2070 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2071 0         0 for my $ord (hex($1) .. hex($2)) {
2072 0         0 my $char = CORE::chr($ord);
2073 0         0 my $uc = Elatin6::uc($char);
2074 0         0 my $fc = Elatin6::fc($char);
2075 0 0       0 if ($uc eq $fc) {
2076 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2077             }
2078             else {
2079 0 0       0 if (CORE::length($fc) == 1) {
2080 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2081 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2082             }
2083             else {
2084 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2085 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2086             }
2087             }
2088             }
2089             }
2090 0 0       0 if ($_ ne '') {
2091 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2092             }
2093             }
2094 0         0 my $i = 0;
2095 0         0 my @singleoctet_ignorecase = ();
2096 0         0 for my $ord (0 .. 255) {
2097 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2098 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2099             }
2100             else {
2101 0         0 $i++;
2102             }
2103             }
2104 0         0 @singleoctet = ();
2105 0         0 for my $range (@singleoctet_ignorecase) {
2106 0 0       0 if (ref $range) {
2107 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2108 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2109             }
2110             elsif (scalar(@{$range}) == 2) {
2111 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2112             }
2113             else {
2114 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2115             }
2116             }
2117             }
2118             }
2119              
2120             # return character list
2121 0 0       0 if (scalar(@multipleoctet) >= 1) {
2122 0 0       0 if (scalar(@singleoctet) >= 1) {
2123              
2124             # any character other than multiple-octet and single octet character class
2125 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2126             }
2127             else {
2128              
2129             # any character other than multiple-octet character class
2130 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2131             }
2132             }
2133             else {
2134 0 0       0 if (scalar(@singleoctet) >= 1) {
2135              
2136             # any character other than single octet character class
2137 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2138             }
2139             else {
2140              
2141             # any character
2142 0         0 return "(?:$your_char)";
2143             }
2144             }
2145             }
2146              
2147             #
2148             # open file in read mode
2149             #
2150             sub _open_r {
2151 200     200   627 my(undef,$file) = @_;
2152 200         819 $file =~ s#\A (\s) #./$1#oxms;
2153 200   33     18297 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2154             open($_[0],"< $file\0");
2155             }
2156              
2157             #
2158             # open file in write mode
2159             #
2160             sub _open_w {
2161 0     0   0 my(undef,$file) = @_;
2162 0         0 $file =~ s#\A (\s) #./$1#oxms;
2163 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2164             open($_[0],"> $file\0");
2165             }
2166              
2167             #
2168             # open file in append mode
2169             #
2170             sub _open_a {
2171 0     0   0 my(undef,$file) = @_;
2172 0         0 $file =~ s#\A (\s) #./$1#oxms;
2173 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2174             open($_[0],">> $file\0");
2175             }
2176              
2177             #
2178             # safe system
2179             #
2180             sub _systemx {
2181              
2182             # P.707 29.2.33. exec
2183             # in Chapter 29: Functions
2184             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2185             #
2186             # Be aware that in older releases of Perl, exec (and system) did not flush
2187             # your output buffer, so you needed to enable command buffering by setting $|
2188             # on one or more filehandles to avoid lost output in the case of exec, or
2189             # misordererd output in the case of system. This situation was largely remedied
2190             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2191              
2192             # P.855 exec
2193             # in Chapter 27: Functions
2194             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2195             #
2196             # In very old release of Perl (before v5.6), exec (and system) did not flush
2197             # your output buffer, so you needed to enable command buffering by setting $|
2198             # on one or more filehandles to avoid lost output with exec or misordered
2199             # output with system.
2200              
2201 200     200   749 $| = 1;
2202              
2203             # P.565 23.1.2. Cleaning Up Your Environment
2204             # in Chapter 23: Security
2205             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2206              
2207             # P.656 Cleaning Up Your Environment
2208             # in Chapter 20: Security
2209             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2210              
2211             # local $ENV{'PATH'} = '.';
2212 200         2166 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2213              
2214             # P.707 29.2.33. exec
2215             # in Chapter 29: Functions
2216             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2217             #
2218             # As we mentioned earlier, exec treats a discrete list of arguments as an
2219             # indication that it should bypass shell processing. However, there is one
2220             # place where you might still get tripped up. The exec call (and system, too)
2221             # will not distinguish between a single scalar argument and an array containing
2222             # only one element.
2223             #
2224             # @args = ("echo surprise"); # just one element in list
2225             # exec @args # still subject to shell escapes
2226             # or die "exec: $!"; # because @args == 1
2227             #
2228             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2229             # first argument as the pathname, which forces the rest of the arguments to be
2230             # interpreted as a list, even if there is only one of them:
2231             #
2232             # exec { $args[0] } @args # safe even with one-argument list
2233             # or die "can't exec @args: $!";
2234              
2235             # P.855 exec
2236             # in Chapter 27: Functions
2237             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2238             #
2239             # As we mentioned earlier, exec treats a discrete list of arguments as a
2240             # directive to bypass shell processing. However, there is one place where
2241             # you might still get tripped up. The exec call (and system, too) cannot
2242             # distinguish between a single scalar argument and an array containing
2243             # only one element.
2244             #
2245             # @args = ("echo surprise"); # just one element in list
2246             # exec @args # still subject to shell escapes
2247             # || die "exec: $!"; # because @args == 1
2248             #
2249             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2250             # argument as the pathname, which forces the rest of the arguments to be
2251             # interpreted as a list, even if there is only one of them:
2252             #
2253             # exec { $args[0] } @args # safe even with one-argument list
2254             # || die "can't exec @args: $!";
2255              
2256 200         419 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         23194354  
2257             }
2258              
2259             #
2260             # Latin-6 order to character (with parameter)
2261             #
2262             sub Elatin6::chr(;$) {
2263              
2264 0 0   0 0   my $c = @_ ? $_[0] : $_;
2265              
2266 0 0         if ($c == 0x00) {
2267 0           return "\x00";
2268             }
2269             else {
2270 0           my @chr = ();
2271 0           while ($c > 0) {
2272 0           unshift @chr, ($c % 0x100);
2273 0           $c = int($c / 0x100);
2274             }
2275 0           return pack 'C*', @chr;
2276             }
2277             }
2278              
2279             #
2280             # Latin-6 order to character (without parameter)
2281             #
2282             sub Elatin6::chr_() {
2283              
2284 0     0 0   my $c = $_;
2285              
2286 0 0         if ($c == 0x00) {
2287 0           return "\x00";
2288             }
2289             else {
2290 0           my @chr = ();
2291 0           while ($c > 0) {
2292 0           unshift @chr, ($c % 0x100);
2293 0           $c = int($c / 0x100);
2294             }
2295 0           return pack 'C*', @chr;
2296             }
2297             }
2298              
2299             #
2300             # Latin-6 path globbing (with parameter)
2301             #
2302             sub Elatin6::glob($) {
2303              
2304 0 0   0 0   if (wantarray) {
2305 0           my @glob = _DOS_like_glob(@_);
2306 0           for my $glob (@glob) {
2307 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2308             }
2309 0           return @glob;
2310             }
2311             else {
2312 0           my $glob = _DOS_like_glob(@_);
2313 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2314 0           return $glob;
2315             }
2316             }
2317              
2318             #
2319             # Latin-6 path globbing (without parameter)
2320             #
2321             sub Elatin6::glob_() {
2322              
2323 0 0   0 0   if (wantarray) {
2324 0           my @glob = _DOS_like_glob();
2325 0           for my $glob (@glob) {
2326 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2327             }
2328 0           return @glob;
2329             }
2330             else {
2331 0           my $glob = _DOS_like_glob();
2332 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2333 0           return $glob;
2334             }
2335             }
2336              
2337             #
2338             # Latin-6 path globbing via File::DosGlob 1.10
2339             #
2340             # Often I confuse "_dosglob" and "_doglob".
2341             # So, I renamed "_dosglob" to "_DOS_like_glob".
2342             #
2343             my %iter;
2344             my %entries;
2345             sub _DOS_like_glob {
2346              
2347             # context (keyed by second cxix argument provided by core)
2348 0     0     my($expr,$cxix) = @_;
2349              
2350             # glob without args defaults to $_
2351 0 0         $expr = $_ if not defined $expr;
2352              
2353             # represents the current user's home directory
2354             #
2355             # 7.3. Expanding Tildes in Filenames
2356             # in Chapter 7. File Access
2357             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2358             #
2359             # and File::HomeDir, File::HomeDir::Windows module
2360              
2361             # DOS-like system
2362 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2363 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2364 0           { my_home_MSWin32() }oxmse;
2365             }
2366              
2367             # UNIX-like system
2368             else {
2369 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2370 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2371             }
2372              
2373             # assume global context if not provided one
2374 0 0         $cxix = '_G_' if not defined $cxix;
2375 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2376              
2377             # if we're just beginning, do it all first
2378 0 0         if ($iter{$cxix} == 0) {
2379 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2380             }
2381              
2382             # chuck it all out, quick or slow
2383 0 0         if (wantarray) {
2384 0           delete $iter{$cxix};
2385 0           return @{delete $entries{$cxix}};
  0            
2386             }
2387             else {
2388 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2389 0           return shift @{$entries{$cxix}};
  0            
2390             }
2391             else {
2392             # return undef for EOL
2393 0           delete $iter{$cxix};
2394 0           delete $entries{$cxix};
2395 0           return undef;
2396             }
2397             }
2398             }
2399              
2400             #
2401             # Latin-6 path globbing subroutine
2402             #
2403             sub _do_glob {
2404              
2405 0     0     my($cond,@expr) = @_;
2406 0           my @glob = ();
2407 0           my $fix_drive_relative_paths = 0;
2408              
2409             OUTER:
2410 0           for my $expr (@expr) {
2411 0 0         next OUTER if not defined $expr;
2412 0 0         next OUTER if $expr eq '';
2413              
2414 0           my @matched = ();
2415 0           my @globdir = ();
2416 0           my $head = '.';
2417 0           my $pathsep = '/';
2418 0           my $tail;
2419              
2420             # if argument is within quotes strip em and do no globbing
2421 0 0         if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2422 0           $expr = $1;
2423 0 0         if ($cond eq 'd') {
2424 0 0         if (-d $expr) {
2425 0           push @glob, $expr;
2426             }
2427             }
2428             else {
2429 0 0         if (-e $expr) {
2430 0           push @glob, $expr;
2431             }
2432             }
2433 0           next OUTER;
2434             }
2435              
2436             # wildcards with a drive prefix such as h:*.pm must be changed
2437             # to h:./*.pm to expand correctly
2438 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2439 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2440 0           $fix_drive_relative_paths = 1;
2441             }
2442             }
2443              
2444 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2445 0 0         if ($tail eq '') {
2446 0           push @glob, $expr;
2447 0           next OUTER;
2448             }
2449 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2450 0 0         if (@globdir = _do_glob('d', $head)) {
2451 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2452 0           next OUTER;
2453             }
2454             }
2455 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2456 0           $head .= $pathsep;
2457             }
2458 0           $expr = $tail;
2459             }
2460              
2461             # If file component has no wildcards, we can avoid opendir
2462 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2463 0 0         if ($head eq '.') {
2464 0           $head = '';
2465             }
2466 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2467 0           $head .= $pathsep;
2468             }
2469 0           $head .= $expr;
2470 0 0         if ($cond eq 'd') {
2471 0 0         if (-d $head) {
2472 0           push @glob, $head;
2473             }
2474             }
2475             else {
2476 0 0         if (-e $head) {
2477 0           push @glob, $head;
2478             }
2479             }
2480 0           next OUTER;
2481             }
2482 0 0         opendir(*DIR, $head) or next OUTER;
2483 0           my @leaf = readdir DIR;
2484 0           closedir DIR;
2485              
2486 0 0         if ($head eq '.') {
2487 0           $head = '';
2488             }
2489 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2490 0           $head .= $pathsep;
2491             }
2492              
2493 0           my $pattern = '';
2494 0           while ($expr =~ / \G ($q_char) /oxgc) {
2495 0           my $char = $1;
2496              
2497             # 6.9. Matching Shell Globs as Regular Expressions
2498             # in Chapter 6. Pattern Matching
2499             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2500             # (and so on)
2501              
2502 0 0         if ($char eq '*') {
    0          
    0          
2503 0           $pattern .= "(?:$your_char)*",
2504             }
2505             elsif ($char eq '?') {
2506 0           $pattern .= "(?:$your_char)?", # DOS style
2507             # $pattern .= "(?:$your_char)", # UNIX style
2508             }
2509             elsif ((my $fc = Elatin6::fc($char)) ne $char) {
2510 0           $pattern .= $fc;
2511             }
2512             else {
2513 0           $pattern .= quotemeta $char;
2514             }
2515             }
2516 0     0     my $matchsub = sub { Elatin6::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2517              
2518             # if ($@) {
2519             # print STDERR "$0: $@\n";
2520             # next OUTER;
2521             # }
2522              
2523             INNER:
2524 0           for my $leaf (@leaf) {
2525 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2526 0           next INNER;
2527             }
2528 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2529 0           next INNER;
2530             }
2531              
2532 0 0         if (&$matchsub($leaf)) {
2533 0           push @matched, "$head$leaf";
2534 0           next INNER;
2535             }
2536              
2537             # [DOS compatibility special case]
2538             # Failed, add a trailing dot and try again, but only...
2539              
2540 0 0 0       if (Elatin6::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2541             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2542             Elatin6::index($pattern,'\\.') != -1 # pattern has a dot.
2543             ) {
2544 0 0         if (&$matchsub("$leaf.")) {
2545 0           push @matched, "$head$leaf";
2546 0           next INNER;
2547             }
2548             }
2549             }
2550 0 0         if (@matched) {
2551 0           push @glob, @matched;
2552             }
2553             }
2554 0 0         if ($fix_drive_relative_paths) {
2555 0           for my $glob (@glob) {
2556 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2557             }
2558             }
2559 0           return @glob;
2560             }
2561              
2562             #
2563             # Latin-6 parse line
2564             #
2565             sub _parse_line {
2566              
2567 0     0     my($line) = @_;
2568              
2569 0           $line .= ' ';
2570 0           my @piece = ();
2571 0           while ($line =~ /
2572             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2573             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2574             /oxmsg
2575             ) {
2576 0 0         push @piece, defined($1) ? $1 : $2;
2577             }
2578 0           return @piece;
2579             }
2580              
2581             #
2582             # Latin-6 parse path
2583             #
2584             sub _parse_path {
2585              
2586 0     0     my($path,$pathsep) = @_;
2587              
2588 0           $path .= '/';
2589 0           my @subpath = ();
2590 0           while ($path =~ /
2591             ((?: [^\/\\] )+?) [\/\\]
2592             /oxmsg
2593             ) {
2594 0           push @subpath, $1;
2595             }
2596              
2597 0           my $tail = pop @subpath;
2598 0           my $head = join $pathsep, @subpath;
2599 0           return $head, $tail;
2600             }
2601              
2602             #
2603             # via File::HomeDir::Windows 1.00
2604             #
2605             sub my_home_MSWin32 {
2606              
2607             # A lot of unix people and unix-derived tools rely on
2608             # the ability to overload HOME. We will support it too
2609             # so that they can replace raw HOME calls with File::HomeDir.
2610 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2611 0           return $ENV{'HOME'};
2612             }
2613              
2614             # Do we have a user profile?
2615             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2616 0           return $ENV{'USERPROFILE'};
2617             }
2618              
2619             # Some Windows use something like $ENV{'HOME'}
2620             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2621 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2622             }
2623              
2624 0           return undef;
2625             }
2626              
2627             #
2628             # via File::HomeDir::Unix 1.00
2629             #
2630             sub my_home {
2631 0     0 0   my $home;
2632              
2633 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2634 0           $home = $ENV{'HOME'};
2635             }
2636              
2637             # This is from the original code, but I'm guessing
2638             # it means "login directory" and exists on some Unixes.
2639             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2640 0           $home = $ENV{'LOGDIR'};
2641             }
2642              
2643             ### More-desperate methods
2644              
2645             # Light desperation on any (Unixish) platform
2646             else {
2647 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2648             }
2649              
2650             # On Unix in general, a non-existant home means "no home"
2651             # For example, "nobody"-like users might use /nonexistant
2652 0 0 0       if (defined $home and ! -d($home)) {
2653 0           $home = undef;
2654             }
2655 0           return $home;
2656             }
2657              
2658             #
2659             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2660             #
2661             sub Elatin6::PREMATCH {
2662 0     0 0   return $`;
2663             }
2664              
2665             #
2666             # ${^MATCH}, $MATCH, $& the string that matched
2667             #
2668             sub Elatin6::MATCH {
2669 0     0 0   return $&;
2670             }
2671              
2672             #
2673             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2674             #
2675             sub Elatin6::POSTMATCH {
2676 0     0 0   return $';
2677             }
2678              
2679             #
2680             # Latin-6 character to order (with parameter)
2681             #
2682             sub Latin6::ord(;$) {
2683              
2684 0 0   0 1   local $_ = shift if @_;
2685              
2686 0 0         if (/\A ($q_char) /oxms) {
2687 0           my @ord = unpack 'C*', $1;
2688 0           my $ord = 0;
2689 0           while (my $o = shift @ord) {
2690 0           $ord = $ord * 0x100 + $o;
2691             }
2692 0           return $ord;
2693             }
2694             else {
2695 0           return CORE::ord $_;
2696             }
2697             }
2698              
2699             #
2700             # Latin-6 character to order (without parameter)
2701             #
2702             sub Latin6::ord_() {
2703              
2704 0 0   0 0   if (/\A ($q_char) /oxms) {
2705 0           my @ord = unpack 'C*', $1;
2706 0           my $ord = 0;
2707 0           while (my $o = shift @ord) {
2708 0           $ord = $ord * 0x100 + $o;
2709             }
2710 0           return $ord;
2711             }
2712             else {
2713 0           return CORE::ord $_;
2714             }
2715             }
2716              
2717             #
2718             # Latin-6 reverse
2719             #
2720             sub Latin6::reverse(@) {
2721              
2722 0 0   0 0   if (wantarray) {
2723 0           return CORE::reverse @_;
2724             }
2725             else {
2726              
2727             # One of us once cornered Larry in an elevator and asked him what
2728             # problem he was solving with this, but he looked as far off into
2729             # the distance as he could in an elevator and said, "It seemed like
2730             # a good idea at the time."
2731              
2732 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2733             }
2734             }
2735              
2736             #
2737             # Latin-6 getc (with parameter, without parameter)
2738             #
2739             sub Latin6::getc(;*@) {
2740              
2741 0     0 0   my($package) = caller;
2742 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2743 0 0 0       croak 'Too many arguments for Latin6::getc' if @_ and not wantarray;
2744              
2745 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2746 0           my $getc = '';
2747 0           for my $length ($length[0] .. $length[-1]) {
2748 0           $getc .= CORE::getc($fh);
2749 0 0         if (exists $range_tr{CORE::length($getc)}) {
2750 0 0         if ($getc =~ /\A ${Elatin6::dot_s} \z/oxms) {
2751 0 0         return wantarray ? ($getc,@_) : $getc;
2752             }
2753             }
2754             }
2755 0 0         return wantarray ? ($getc,@_) : $getc;
2756             }
2757              
2758             #
2759             # Latin-6 length by character
2760             #
2761             sub Latin6::length(;$) {
2762              
2763 0 0   0 1   local $_ = shift if @_;
2764              
2765 0           local @_ = /\G ($q_char) /oxmsg;
2766 0           return scalar @_;
2767             }
2768              
2769             #
2770             # Latin-6 substr by character
2771             #
2772             BEGIN {
2773              
2774             # P.232 The lvalue Attribute
2775             # in Chapter 6: Subroutines
2776             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2777              
2778             # P.336 The lvalue Attribute
2779             # in Chapter 7: Subroutines
2780             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2781              
2782             # P.144 8.4 Lvalue subroutines
2783             # in Chapter 8: perlsub: Perl subroutines
2784             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2785              
2786 200 50 0 200 1 149619 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  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            
2787             # vv----------------------*******
2788             sub Latin6::substr($$;$$) %s {
2789              
2790             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2791              
2792             # If the substring is beyond either end of the string, substr() returns the undefined
2793             # value and produces a warning. When used as an lvalue, specifying a substring that
2794             # is entirely outside the string raises an exception.
2795             # http://perldoc.perl.org/functions/substr.html
2796              
2797             # A return with no argument returns the scalar value undef in scalar context,
2798             # an empty list () in list context, and (naturally) nothing at all in void
2799             # context.
2800              
2801             my $offset = $_[1];
2802             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2803             return;
2804             }
2805              
2806             # substr($string,$offset,$length,$replacement)
2807             if (@_ == 4) {
2808             my(undef,undef,$length,$replacement) = @_;
2809             my $substr = join '', splice(@char, $offset, $length, $replacement);
2810             $_[0] = join '', @char;
2811              
2812             # return $substr; this doesn't work, don't say "return"
2813             $substr;
2814             }
2815              
2816             # substr($string,$offset,$length)
2817             elsif (@_ == 3) {
2818             my(undef,undef,$length) = @_;
2819             my $octet_offset = 0;
2820             my $octet_length = 0;
2821             if ($offset == 0) {
2822             $octet_offset = 0;
2823             }
2824             elsif ($offset > 0) {
2825             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2826             }
2827             else {
2828             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2829             }
2830             if ($length == 0) {
2831             $octet_length = 0;
2832             }
2833             elsif ($length > 0) {
2834             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2835             }
2836             else {
2837             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2838             }
2839             CORE::substr($_[0], $octet_offset, $octet_length);
2840             }
2841              
2842             # substr($string,$offset)
2843             else {
2844             my $octet_offset = 0;
2845             if ($offset == 0) {
2846             $octet_offset = 0;
2847             }
2848             elsif ($offset > 0) {
2849             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2850             }
2851             else {
2852             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2853             }
2854             CORE::substr($_[0], $octet_offset);
2855             }
2856             }
2857             END
2858             }
2859              
2860             #
2861             # Latin-6 index by character
2862             #
2863             sub Latin6::index($$;$) {
2864              
2865 0     0 1   my $index;
2866 0 0         if (@_ == 3) {
2867 0           $index = Elatin6::index($_[0], $_[1], CORE::length(Latin6::substr($_[0], 0, $_[2])));
2868             }
2869             else {
2870 0           $index = Elatin6::index($_[0], $_[1]);
2871             }
2872              
2873 0 0         if ($index == -1) {
2874 0           return -1;
2875             }
2876             else {
2877 0           return Latin6::length(CORE::substr $_[0], 0, $index);
2878             }
2879             }
2880              
2881             #
2882             # Latin-6 rindex by character
2883             #
2884             sub Latin6::rindex($$;$) {
2885              
2886 0     0 1   my $rindex;
2887 0 0         if (@_ == 3) {
2888 0           $rindex = Elatin6::rindex($_[0], $_[1], CORE::length(Latin6::substr($_[0], 0, $_[2])));
2889             }
2890             else {
2891 0           $rindex = Elatin6::rindex($_[0], $_[1]);
2892             }
2893              
2894 0 0         if ($rindex == -1) {
2895 0           return -1;
2896             }
2897             else {
2898 0           return Latin6::length(CORE::substr $_[0], 0, $rindex);
2899             }
2900             }
2901              
2902             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2903             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2904 200     200   18890 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   2164  
  200         475  
  200         16223  
2905              
2906             # ord() to ord() or Latin6::ord()
2907 200     200   13655 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1209  
  200         417  
  200         12337  
2908              
2909             # ord to ord or Latin6::ord_
2910 200     200   14710 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   1172  
  200         368  
  200         12582  
2911              
2912             # reverse to reverse or Latin6::reverse
2913 200     200   13969 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   1259  
  200         419  
  200         13512  
2914              
2915             # getc to getc or Latin6::getc
2916 200     200   14760 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   1190  
  200         438  
  200         16386  
2917              
2918             # P.1023 Appendix W.9 Multibyte Anchoring
2919             # of ISBN 1-56592-224-7 CJKV Information Processing
2920              
2921             my $anchor = '';
2922              
2923 200     200   13867 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   1121  
  200         361  
  200         12265616  
2924              
2925             # regexp of nested parens in qqXX
2926              
2927             # P.340 Matching Nested Constructs with Embedded Code
2928             # in Chapter 7: Perl
2929             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2930              
2931             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2932             [^\\()] |
2933             \( (?{$nest++}) |
2934             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2935             \\ [^c] |
2936             \\c[\x40-\x5F] |
2937             [\x00-\xFF]
2938             }xms;
2939              
2940             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2941             [^\\{}] |
2942             \{ (?{$nest++}) |
2943             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2944             \\ [^c] |
2945             \\c[\x40-\x5F] |
2946             [\x00-\xFF]
2947             }xms;
2948              
2949             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2950             [^\\\[\]] |
2951             \[ (?{$nest++}) |
2952             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2953             \\ [^c] |
2954             \\c[\x40-\x5F] |
2955             [\x00-\xFF]
2956             }xms;
2957              
2958             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2959             [^\\<>] |
2960             \< (?{$nest++}) |
2961             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2962             \\ [^c] |
2963             \\c[\x40-\x5F] |
2964             [\x00-\xFF]
2965             }xms;
2966              
2967             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2968             (?: ::)? (?:
2969             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2970             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2971             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2972             ))
2973             }xms;
2974              
2975             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2976             (?: ::)? (?:
2977             (?>[0-9]+) |
2978             [^a-zA-Z_0-9\[\]] |
2979             ^[A-Z] |
2980             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2981             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2982             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2983             ))
2984             }xms;
2985              
2986             my $qq_substr = qr{(?> Char::substr | Latin6::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2987             }xms;
2988              
2989             # regexp of nested parens in qXX
2990             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2991             [^()] |
2992             \( (?{$nest++}) |
2993             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2994             [\x00-\xFF]
2995             }xms;
2996              
2997             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2998             [^\{\}] |
2999             \{ (?{$nest++}) |
3000             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3001             [\x00-\xFF]
3002             }xms;
3003              
3004             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
3005             [^\[\]] |
3006             \[ (?{$nest++}) |
3007             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3008             [\x00-\xFF]
3009             }xms;
3010              
3011             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3012             [^<>] |
3013             \< (?{$nest++}) |
3014             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3015             [\x00-\xFF]
3016             }xms;
3017              
3018             my $matched = '';
3019             my $s_matched = '';
3020              
3021             my $tr_variable = ''; # variable of tr///
3022             my $sub_variable = ''; # variable of s///
3023             my $bind_operator = ''; # =~ or !~
3024              
3025             my @heredoc = (); # here document
3026             my @heredoc_delimiter = ();
3027             my $here_script = ''; # here script
3028              
3029             #
3030             # escape Latin-6 script
3031             #
3032             sub Latin6::escape(;$) {
3033 0 0   0 0   local($_) = $_[0] if @_;
3034              
3035             # P.359 The Study Function
3036             # in Chapter 7: Perl
3037             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3038              
3039 0           study $_; # Yes, I studied study yesterday.
3040              
3041             # while all script
3042              
3043             # 6.14. Matching from Where the Last Pattern Left Off
3044             # in Chapter 6. Pattern Matching
3045             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3046             # (and so on)
3047              
3048             # one member of Tag-team
3049             #
3050             # P.128 Start of match (or end of previous match): \G
3051             # P.130 Advanced Use of \G with Perl
3052             # in Chapter 3: Overview of Regular Expression Features and Flavors
3053             # P.255 Use leading anchors
3054             # P.256 Expose ^ and \G at the front expressions
3055             # in Chapter 6: Crafting an Efficient Expression
3056             # P.315 "Tag-team" matching with /gc
3057             # in Chapter 7: Perl
3058             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3059              
3060 0           my $e_script = '';
3061 0           while (not /\G \z/oxgc) { # member
3062 0           $e_script .= Latin6::escape_token();
3063             }
3064              
3065 0           return $e_script;
3066             }
3067              
3068             #
3069             # escape Latin-6 token of script
3070             #
3071             sub Latin6::escape_token {
3072              
3073             # \n output here document
3074              
3075 0     0 0   my $ignore_modules = join('|', qw(
3076             utf8
3077             bytes
3078             charnames
3079             I18N::Japanese
3080             I18N::Collate
3081             I18N::JExt
3082             File::DosGlob
3083             Wild
3084             Wildcard
3085             Japanese
3086             ));
3087              
3088             # another member of Tag-team
3089             #
3090             # P.315 "Tag-team" matching with /gc
3091             # in Chapter 7: Perl
3092             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3093              
3094 0 0 0       if (/\G ( \n ) /oxgc) { # another member (and so on)
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    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          
3095 0           my $heredoc = '';
3096 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3097 0           $slash = 'm//';
3098              
3099 0           $heredoc = join '', @heredoc;
3100 0           @heredoc = ();
3101              
3102             # skip here document
3103 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3104 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3105             }
3106 0           @heredoc_delimiter = ();
3107              
3108 0           $here_script = '';
3109             }
3110 0           return "\n" . $heredoc;
3111             }
3112              
3113             # ignore space, comment
3114 0           elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3115              
3116             # if (, elsif (, unless (, while (, until (, given (, and when (
3117              
3118             # given, when
3119              
3120             # P.225 The given Statement
3121             # in Chapter 15: Smart Matching and given-when
3122             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3123              
3124             # P.133 The given Statement
3125             # in Chapter 4: Statements and Declarations
3126             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3127              
3128             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3129 0           $slash = 'm//';
3130 0           return $1;
3131             }
3132              
3133             # scalar variable ($scalar = ...) =~ tr///;
3134             # scalar variable ($scalar = ...) =~ s///;
3135              
3136             # state
3137              
3138             # P.68 Persistent, Private Variables
3139             # in Chapter 4: Subroutines
3140             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3141              
3142             # P.160 Persistent Lexically Scoped Variables: state
3143             # in Chapter 4: Statements and Declarations
3144             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3145              
3146             # (and so on)
3147              
3148             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3149 0           my $e_string = e_string($1);
3150              
3151 0 0         if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3152 0           $tr_variable = $e_string . e_string($1);
3153 0           $bind_operator = $2;
3154 0           $slash = 'm//';
3155 0           return '';
3156             }
3157             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3158 0           $sub_variable = $e_string . e_string($1);
3159 0           $bind_operator = $2;
3160 0           $slash = 'm//';
3161 0           return '';
3162             }
3163             else {
3164 0           $slash = 'div';
3165 0           return $e_string;
3166             }
3167             }
3168              
3169             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
3170             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3171 0           $slash = 'div';
3172 0           return q{Elatin6::PREMATCH()};
3173             }
3174              
3175             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
3176             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3177 0           $slash = 'div';
3178 0           return q{Elatin6::MATCH()};
3179             }
3180              
3181             # $', ${'} --> $', ${'}
3182             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3183 0           $slash = 'div';
3184 0           return $1;
3185             }
3186              
3187             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
3188             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3189 0           $slash = 'div';
3190 0           return q{Elatin6::POSTMATCH()};
3191             }
3192              
3193             # scalar variable $scalar =~ tr///;
3194             # scalar variable $scalar =~ s///;
3195             # substr() =~ tr///;
3196             # substr() =~ s///;
3197             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3198 0           my $scalar = e_string($1);
3199              
3200 0 0         if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3201 0           $tr_variable = $scalar;
3202 0           $bind_operator = $1;
3203 0           $slash = 'm//';
3204 0           return '';
3205             }
3206             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3207 0           $sub_variable = $scalar;
3208 0           $bind_operator = $1;
3209 0           $slash = 'm//';
3210 0           return '';
3211             }
3212             else {
3213 0           $slash = 'div';
3214 0           return $scalar;
3215             }
3216             }
3217              
3218             # end of statement
3219             elsif (/\G ( [,;] ) /oxgc) {
3220 0           $slash = 'm//';
3221              
3222             # clear tr/// variable
3223 0           $tr_variable = '';
3224              
3225             # clear s/// variable
3226 0           $sub_variable = '';
3227              
3228 0           $bind_operator = '';
3229              
3230 0           return $1;
3231             }
3232              
3233             # bareword
3234             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3235 0           return $1;
3236             }
3237              
3238             # $0 --> $0
3239             elsif (/\G ( \$ 0 ) /oxmsgc) {
3240 0           $slash = 'div';
3241 0           return $1;
3242             }
3243             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3244 0           $slash = 'div';
3245 0           return $1;
3246             }
3247              
3248             # $$ --> $$
3249             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3250 0           $slash = 'div';
3251 0           return $1;
3252             }
3253              
3254             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3255             # $1, $2, $3 --> $1, $2, $3 otherwise
3256             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3257 0           $slash = 'div';
3258 0           return e_capture($1);
3259             }
3260             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3261 0           $slash = 'div';
3262 0           return e_capture($1);
3263             }
3264              
3265             # $$foo[ ... ] --> $ $foo->[ ... ]
3266             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3267 0           $slash = 'div';
3268 0           return e_capture($1.'->'.$2);
3269             }
3270              
3271             # $$foo{ ... } --> $ $foo->{ ... }
3272             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3273 0           $slash = 'div';
3274 0           return e_capture($1.'->'.$2);
3275             }
3276              
3277             # $$foo
3278             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3279 0           $slash = 'div';
3280 0           return e_capture($1);
3281             }
3282              
3283             # ${ foo }
3284             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3285 0           $slash = 'div';
3286 0           return '${' . $1 . '}';
3287             }
3288              
3289             # ${ ... }
3290             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3291 0           $slash = 'div';
3292 0           return e_capture($1);
3293             }
3294              
3295             # variable or function
3296             # $ @ % & * $ #
3297             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) {
3298 0           $slash = 'div';
3299 0           return $1;
3300             }
3301             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3302             # $ @ # \ ' " / ? ( ) [ ] < >
3303             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3304 0           $slash = 'div';
3305 0           return $1;
3306             }
3307              
3308             # while ()
3309             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3310 0           return $1;
3311             }
3312              
3313             # while () --- glob
3314              
3315             # avoid "Error: Runtime exception" of perl version 5.005_03
3316              
3317             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3318 0           return 'while ($_ = Elatin6::glob("' . $1 . '"))';
3319             }
3320              
3321             # while (glob)
3322             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3323 0           return 'while ($_ = Elatin6::glob_)';
3324             }
3325              
3326             # while (glob(WILDCARD))
3327             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3328 0           return 'while ($_ = Elatin6::glob';
3329             }
3330              
3331             # doit if, doit unless, doit while, doit until, doit for, doit when
3332 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3333              
3334             # subroutines of package Elatin6
3335 0           elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3336 0           elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3337 0           elsif (/\G \b Latin6::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3338 0           elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0            
3339 0           elsif (/\G \b Latin6::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin6::escape'; }
  0            
3340 0           elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3341 0           elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::chop'; }
  0            
3342 0           elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3343 0           elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0            
3344 0           elsif (/\G \b Latin6::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin6::index'; }
  0            
3345 0           elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::index'; }
  0            
3346 0           elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3347 0           elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0            
3348 0           elsif (/\G \b Latin6::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin6::rindex'; }
  0            
3349 0           elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::rindex'; }
  0            
3350 0           elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::lc'; }
  0            
3351 0           elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::lcfirst'; }
  0            
3352 0           elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::uc'; }
  0            
3353 0           elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::ucfirst'; }
  0            
3354 0           elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::fc'; }
  0            
3355              
3356             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3357 0           elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3358 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3359 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3360 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3361 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3362 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3363 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3364              
3365 0           elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3366 0           elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3367 0           elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3368 0           elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3369 0           elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3370 0           elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3371 0           elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3372              
3373             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3374 0           { $slash = 'm//'; return "-s $1"; }
  0            
3375 0           elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3376 0           elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3377 0           elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3378              
3379 0           elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3380 0           elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3381 0           elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::chr'; }
  0            
3382 0           elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3383 0           elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3384 0           elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin6::glob'; }
  0            
3385 0           elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::lc_'; }
  0            
3386 0           elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::lcfirst_'; }
  0            
3387 0           elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::uc_'; }
  0            
3388 0           elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::ucfirst_'; }
  0            
3389 0           elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::fc_'; }
  0            
3390 0           elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3391              
3392 0           elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3393 0           elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3394 0           elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::chr_'; }
  0            
3395 0           elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3396 0           elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3397 0           elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin6::glob_'; }
  0            
3398 0           elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3399 0           elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3400             # split
3401             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3402 0           $slash = 'm//';
3403              
3404 0           my $e = '';
3405 0           while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3406 0           $e .= $1;
3407             }
3408              
3409             # end of split
3410 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin6::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3411              
3412             # split scalar value
3413 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin6::split' . $e . e_string($1); }
3414              
3415             # split literal space
3416 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin6::split' . $e . qq {qq$1 $2}; }
3417 0           elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3418 0           elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3419 0           elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3420 0           elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3421 0           elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin6::split' . $e . qq{$1qq$2 $3}; }
3422 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin6::split' . $e . qq {q$1 $2}; }
3423 0           elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3424 0           elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3425 0           elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3426 0           elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3427 0           elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin6::split' . $e . qq {$1q$2 $3}; }
3428 0           elsif (/\G ' [ ] ' /oxgc) { return 'Elatin6::split' . $e . qq {' '}; }
3429 0           elsif (/\G " [ ] " /oxgc) { return 'Elatin6::split' . $e . qq {" "}; }
3430              
3431             # split qq//
3432             elsif (/\G \b (qq) \b /oxgc) {
3433 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3434             else {
3435 0           while (not /\G \z/oxgc) {
3436 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3437 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3438 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3439 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3440 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3441 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3442 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3443             }
3444 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3445             }
3446             }
3447              
3448             # split qr//
3449             elsif (/\G \b (qr) \b /oxgc) {
3450 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3451             else {
3452 0           while (not /\G \z/oxgc) {
3453 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3454 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3455 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3456 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3457 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3458 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3459 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3460 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3461             }
3462 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3463             }
3464             }
3465              
3466             # split q//
3467             elsif (/\G \b (q) \b /oxgc) {
3468 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3469             else {
3470 0           while (not /\G \z/oxgc) {
3471 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3472 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3473 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3474 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3475 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3476 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3477 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3478             }
3479 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3480             }
3481             }
3482              
3483             # split m//
3484             elsif (/\G \b (m) \b /oxgc) {
3485 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3486             else {
3487 0           while (not /\G \z/oxgc) {
3488 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3489 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3490 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3491 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3492 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3493 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3494 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3495 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3496             }
3497 0           die __FILE__, ": Search pattern not terminated\n";
3498             }
3499             }
3500              
3501             # split ''
3502             elsif (/\G (\') /oxgc) {
3503 0           my $q_string = '';
3504 0           while (not /\G \z/oxgc) {
3505 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3506 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3507 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3508 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3509             }
3510 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3511             }
3512              
3513             # split ""
3514             elsif (/\G (\") /oxgc) {
3515 0           my $qq_string = '';
3516 0           while (not /\G \z/oxgc) {
3517 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3518 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3519 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3520 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3521             }
3522 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3523             }
3524              
3525             # split //
3526             elsif (/\G (\/) /oxgc) {
3527 0           my $regexp = '';
3528 0           while (not /\G \z/oxgc) {
3529 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3530 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3531 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3532 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3533             }
3534 0           die __FILE__, ": Search pattern not terminated\n";
3535             }
3536             }
3537              
3538             # tr/// or y///
3539              
3540             # about [cdsrbB]* (/B modifier)
3541             #
3542             # P.559 appendix C
3543             # of ISBN 4-89052-384-7 Programming perl
3544             # (Japanese title is: Perl puroguramingu)
3545              
3546             elsif (/\G \b ( tr | y ) \b /oxgc) {
3547 0           my $ope = $1;
3548              
3549             # $1 $2 $3 $4 $5 $6
3550 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3551 0           my @tr = ($tr_variable,$2);
3552 0           return e_tr(@tr,'',$4,$6);
3553             }
3554             else {
3555 0           my $e = '';
3556 0           while (not /\G \z/oxgc) {
3557 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3558             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3559 0           my @tr = ($tr_variable,$2);
3560 0           while (not /\G \z/oxgc) {
3561 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3562 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3563 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3564 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3565 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3566 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3567             }
3568 0           die __FILE__, ": Transliteration replacement not terminated\n";
3569             }
3570             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3571 0           my @tr = ($tr_variable,$2);
3572 0           while (not /\G \z/oxgc) {
3573 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3574 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3575 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3576 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3577 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3578 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3579             }
3580 0           die __FILE__, ": Transliteration replacement not terminated\n";
3581             }
3582             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3583 0           my @tr = ($tr_variable,$2);
3584 0           while (not /\G \z/oxgc) {
3585 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3586 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3587 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3588 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3589 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3590 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3591             }
3592 0           die __FILE__, ": Transliteration replacement not terminated\n";
3593             }
3594             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3595 0           my @tr = ($tr_variable,$2);
3596 0           while (not /\G \z/oxgc) {
3597 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3598 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3599 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3600 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3601 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3602 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3603             }
3604 0           die __FILE__, ": Transliteration replacement not terminated\n";
3605             }
3606             # $1 $2 $3 $4 $5 $6
3607             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3608 0           my @tr = ($tr_variable,$2);
3609 0           return e_tr(@tr,'',$4,$6);
3610             }
3611             }
3612 0           die __FILE__, ": Transliteration pattern not terminated\n";
3613             }
3614             }
3615              
3616             # qq//
3617             elsif (/\G \b (qq) \b /oxgc) {
3618 0           my $ope = $1;
3619              
3620             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3621 0 0         if (/\G (\#) /oxgc) { # qq# #
3622 0           my $qq_string = '';
3623 0           while (not /\G \z/oxgc) {
3624 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3625 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3626 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3627 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3628             }
3629 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3630             }
3631              
3632             else {
3633 0           my $e = '';
3634 0           while (not /\G \z/oxgc) {
3635 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3636              
3637             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3638             elsif (/\G (\() /oxgc) { # qq ( )
3639 0           my $qq_string = '';
3640 0           local $nest = 1;
3641 0           while (not /\G \z/oxgc) {
3642 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3643 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3644 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3645             elsif (/\G (\)) /oxgc) {
3646 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3647 0           else { $qq_string .= $1; }
3648             }
3649 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3650             }
3651 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3652             }
3653              
3654             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3655             elsif (/\G (\{) /oxgc) { # qq { }
3656 0           my $qq_string = '';
3657 0           local $nest = 1;
3658 0           while (not /\G \z/oxgc) {
3659 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3660 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3661 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3662             elsif (/\G (\}) /oxgc) {
3663 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3664 0           else { $qq_string .= $1; }
3665             }
3666 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3667             }
3668 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3669             }
3670              
3671             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3672             elsif (/\G (\[) /oxgc) { # qq [ ]
3673 0           my $qq_string = '';
3674 0           local $nest = 1;
3675 0           while (not /\G \z/oxgc) {
3676 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3677 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3678 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3679             elsif (/\G (\]) /oxgc) {
3680 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3681 0           else { $qq_string .= $1; }
3682             }
3683 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3684             }
3685 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3686             }
3687              
3688             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3689             elsif (/\G (\<) /oxgc) { # qq < >
3690 0           my $qq_string = '';
3691 0           local $nest = 1;
3692 0           while (not /\G \z/oxgc) {
3693 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3694 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3695 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3696             elsif (/\G (\>) /oxgc) {
3697 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3698 0           else { $qq_string .= $1; }
3699             }
3700 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3701             }
3702 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3703             }
3704              
3705             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3706             elsif (/\G (\S) /oxgc) { # qq * *
3707 0           my $delimiter = $1;
3708 0           my $qq_string = '';
3709 0           while (not /\G \z/oxgc) {
3710 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3711 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3712 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3713 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3714             }
3715 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3716             }
3717             }
3718 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3719             }
3720             }
3721              
3722             # qr//
3723             elsif (/\G \b (qr) \b /oxgc) {
3724 0           my $ope = $1;
3725 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3726 0           return e_qr($ope,$1,$3,$2,$4);
3727             }
3728             else {
3729 0           my $e = '';
3730 0           while (not /\G \z/oxgc) {
3731 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3732 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3733 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3734 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3735 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3736 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3737 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3738 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3739             }
3740 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3741             }
3742             }
3743              
3744             # qw//
3745             elsif (/\G \b (qw) \b /oxgc) {
3746 0           my $ope = $1;
3747 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3748 0           return e_qw($ope,$1,$3,$2);
3749             }
3750             else {
3751 0           my $e = '';
3752 0           while (not /\G \z/oxgc) {
3753 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3754              
3755 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3756 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3757              
3758 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3759 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3760              
3761 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3762 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3763              
3764 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3765 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3766              
3767 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3768 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3769             }
3770 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3771             }
3772             }
3773              
3774             # qx//
3775             elsif (/\G \b (qx) \b /oxgc) {
3776 0           my $ope = $1;
3777 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3778 0           return e_qq($ope,$1,$3,$2);
3779             }
3780             else {
3781 0           my $e = '';
3782 0           while (not /\G \z/oxgc) {
3783 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3784 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3785 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3786 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3787 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3788 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3789 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3790             }
3791 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3792             }
3793             }
3794              
3795             # q//
3796             elsif (/\G \b (q) \b /oxgc) {
3797 0           my $ope = $1;
3798              
3799             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3800              
3801             # avoid "Error: Runtime exception" of perl version 5.005_03
3802             # (and so on)
3803              
3804 0 0         if (/\G (\#) /oxgc) { # q# #
3805 0           my $q_string = '';
3806 0           while (not /\G \z/oxgc) {
3807 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3808 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3809 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3810 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3811             }
3812 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3813             }
3814              
3815             else {
3816 0           my $e = '';
3817 0           while (not /\G \z/oxgc) {
3818 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3819              
3820             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3821             elsif (/\G (\() /oxgc) { # q ( )
3822 0           my $q_string = '';
3823 0           local $nest = 1;
3824 0           while (not /\G \z/oxgc) {
3825 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3826 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3827 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3828 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3829             elsif (/\G (\)) /oxgc) {
3830 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3831 0           else { $q_string .= $1; }
3832             }
3833 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3834             }
3835 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3836             }
3837              
3838             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3839             elsif (/\G (\{) /oxgc) { # q { }
3840 0           my $q_string = '';
3841 0           local $nest = 1;
3842 0           while (not /\G \z/oxgc) {
3843 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3844 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3845 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3846 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3847             elsif (/\G (\}) /oxgc) {
3848 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3849 0           else { $q_string .= $1; }
3850             }
3851 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3852             }
3853 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3854             }
3855              
3856             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3857             elsif (/\G (\[) /oxgc) { # q [ ]
3858 0           my $q_string = '';
3859 0           local $nest = 1;
3860 0           while (not /\G \z/oxgc) {
3861 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3862 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3863 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3864 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3865             elsif (/\G (\]) /oxgc) {
3866 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3867 0           else { $q_string .= $1; }
3868             }
3869 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3870             }
3871 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3872             }
3873              
3874             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3875             elsif (/\G (\<) /oxgc) { # q < >
3876 0           my $q_string = '';
3877 0           local $nest = 1;
3878 0           while (not /\G \z/oxgc) {
3879 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3880 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3881 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3882 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3883             elsif (/\G (\>) /oxgc) {
3884 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3885 0           else { $q_string .= $1; }
3886             }
3887 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3888             }
3889 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3890             }
3891              
3892             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3893             elsif (/\G (\S) /oxgc) { # q * *
3894 0           my $delimiter = $1;
3895 0           my $q_string = '';
3896 0           while (not /\G \z/oxgc) {
3897 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3898 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3899 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3900 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3901             }
3902 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3903             }
3904             }
3905 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3906             }
3907             }
3908              
3909             # m//
3910             elsif (/\G \b (m) \b /oxgc) {
3911 0           my $ope = $1;
3912 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3913 0           return e_qr($ope,$1,$3,$2,$4);
3914             }
3915             else {
3916 0           my $e = '';
3917 0           while (not /\G \z/oxgc) {
3918 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3919 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3920 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3921 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3922 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3923 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3924 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3925 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3926 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3927             }
3928 0           die __FILE__, ": Search pattern not terminated\n";
3929             }
3930             }
3931              
3932             # s///
3933              
3934             # about [cegimosxpradlunbB]* (/cg modifier)
3935             #
3936             # P.67 Pattern-Matching Operators
3937             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3938              
3939             elsif (/\G \b (s) \b /oxgc) {
3940 0           my $ope = $1;
3941              
3942             # $1 $2 $3 $4 $5 $6
3943 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3944 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3945             }
3946             else {
3947 0           my $e = '';
3948 0           while (not /\G \z/oxgc) {
3949 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3950             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3951 0           my @s = ($1,$2,$3);
3952 0           while (not /\G \z/oxgc) {
3953 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3954             # $1 $2 $3 $4
3955 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964             }
3965 0           die __FILE__, ": Substitution replacement not terminated\n";
3966             }
3967             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3968 0           my @s = ($1,$2,$3);
3969 0           while (not /\G \z/oxgc) {
3970 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3971             # $1 $2 $3 $4
3972 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981             }
3982 0           die __FILE__, ": Substitution replacement not terminated\n";
3983             }
3984             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3985 0           my @s = ($1,$2,$3);
3986 0           while (not /\G \z/oxgc) {
3987 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3988             # $1 $2 $3 $4
3989 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3990 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3991 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3992 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3993 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3994 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3995 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996             }
3997 0           die __FILE__, ": Substitution replacement not terminated\n";
3998             }
3999             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
4000 0           my @s = ($1,$2,$3);
4001 0           while (not /\G \z/oxgc) {
4002 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4003             # $1 $2 $3 $4
4004 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4005 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4006 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4007 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4008 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4009 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4010 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4011 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4012 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4013             }
4014 0           die __FILE__, ": Substitution replacement not terminated\n";
4015             }
4016             # $1 $2 $3 $4 $5 $6
4017             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4018 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4019             }
4020             # $1 $2 $3 $4 $5 $6
4021             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4022 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4023             }
4024             # $1 $2 $3 $4 $5 $6
4025             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4026 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4027             }
4028             # $1 $2 $3 $4 $5 $6
4029             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4030 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4031             }
4032             }
4033 0           die __FILE__, ": Substitution pattern not terminated\n";
4034             }
4035             }
4036              
4037             # require ignore module
4038 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4039 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4040 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4041              
4042             # use strict; --> use strict; no strict qw(refs);
4043 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4044 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4045 0           elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4046              
4047             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4048             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4049 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
4050 0           return "use $1; no strict qw(refs);";
4051             }
4052             else {
4053 0           return "use $1;";
4054             }
4055             }
4056             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4057 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4058 0           return "use $1; no strict qw(refs);";
4059             }
4060             else {
4061 0           return "use $1;";
4062             }
4063             }
4064              
4065             # ignore use module
4066 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4067 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4068 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4069              
4070             # ignore no module
4071 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4072 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4073 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4074              
4075             # use else
4076 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4077              
4078             # use else
4079 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4080              
4081             # ''
4082             elsif (/\G (?
4083 0           my $q_string = '';
4084 0           while (not /\G \z/oxgc) {
4085 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4086 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4087 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4088 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4089             }
4090 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4091             }
4092              
4093             # ""
4094             elsif (/\G (\") /oxgc) {
4095 0           my $qq_string = '';
4096 0           while (not /\G \z/oxgc) {
4097 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4098 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4099 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4100 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4101             }
4102 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4103             }
4104              
4105             # ``
4106             elsif (/\G (\`) /oxgc) {
4107 0           my $qx_string = '';
4108 0           while (not /\G \z/oxgc) {
4109 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4110 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4111 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4112 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4113             }
4114 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4115             }
4116              
4117             # // --- not divide operator (num / num), not defined-or
4118             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4119 0           my $regexp = '';
4120 0           while (not /\G \z/oxgc) {
4121 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4122 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4123 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4124 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4125             }
4126 0           die __FILE__, ": Search pattern not terminated\n";
4127             }
4128              
4129             # ?? --- not conditional operator (condition ? then : else)
4130             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4131 0           my $regexp = '';
4132 0           while (not /\G \z/oxgc) {
4133 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4134 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4135 0           elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4136 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4137             }
4138 0           die __FILE__, ": Search pattern not terminated\n";
4139             }
4140              
4141             # <<>> (a safer ARGV)
4142 0           elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4143              
4144             # << (bit shift) --- not here document
4145 0           elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4146              
4147             # <<'HEREDOC'
4148             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4149 0           $slash = 'm//';
4150 0           my $here_quote = $1;
4151 0           my $delimiter = $2;
4152              
4153             # get here document
4154 0 0         if ($here_script eq '') {
4155 0           $here_script = CORE::substr $_, pos $_;
4156 0           $here_script =~ s/.*?\n//oxm;
4157             }
4158 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4159 0           push @heredoc, $1 . qq{\n$delimiter\n};
4160 0           push @heredoc_delimiter, $delimiter;
4161             }
4162             else {
4163 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4164             }
4165 0           return $here_quote;
4166             }
4167              
4168             # <<\HEREDOC
4169              
4170             # P.66 2.6.6. "Here" Documents
4171             # in Chapter 2: Bits and Pieces
4172             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4173              
4174             # P.73 "Here" Documents
4175             # in Chapter 2: Bits and Pieces
4176             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4177              
4178             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4179 0           $slash = 'm//';
4180 0           my $here_quote = $1;
4181 0           my $delimiter = $2;
4182              
4183             # get here document
4184 0 0         if ($here_script eq '') {
4185 0           $here_script = CORE::substr $_, pos $_;
4186 0           $here_script =~ s/.*?\n//oxm;
4187             }
4188 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4189 0           push @heredoc, $1 . qq{\n$delimiter\n};
4190 0           push @heredoc_delimiter, $delimiter;
4191             }
4192             else {
4193 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4194             }
4195 0           return $here_quote;
4196             }
4197              
4198             # <<"HEREDOC"
4199             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4200 0           $slash = 'm//';
4201 0           my $here_quote = $1;
4202 0           my $delimiter = $2;
4203              
4204             # get here document
4205 0 0         if ($here_script eq '') {
4206 0           $here_script = CORE::substr $_, pos $_;
4207 0           $here_script =~ s/.*?\n//oxm;
4208             }
4209 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4210 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4211 0           push @heredoc_delimiter, $delimiter;
4212             }
4213             else {
4214 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4215             }
4216 0           return $here_quote;
4217             }
4218              
4219             # <
4220             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4221 0           $slash = 'm//';
4222 0           my $here_quote = $1;
4223 0           my $delimiter = $2;
4224              
4225             # get here document
4226 0 0         if ($here_script eq '') {
4227 0           $here_script = CORE::substr $_, pos $_;
4228 0           $here_script =~ s/.*?\n//oxm;
4229             }
4230 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4231 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4232 0           push @heredoc_delimiter, $delimiter;
4233             }
4234             else {
4235 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4236             }
4237 0           return $here_quote;
4238             }
4239              
4240             # <<`HEREDOC`
4241             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4242 0           $slash = 'm//';
4243 0           my $here_quote = $1;
4244 0           my $delimiter = $2;
4245              
4246             # get here document
4247 0 0         if ($here_script eq '') {
4248 0           $here_script = CORE::substr $_, pos $_;
4249 0           $here_script =~ s/.*?\n//oxm;
4250             }
4251 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4252 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4253 0           push @heredoc_delimiter, $delimiter;
4254             }
4255             else {
4256 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4257             }
4258 0           return $here_quote;
4259             }
4260              
4261             # <<= <=> <= < operator
4262             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4263 0           return $1;
4264             }
4265              
4266             #
4267             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4268 0           return $1;
4269             }
4270              
4271             # --- glob
4272              
4273             # avoid "Error: Runtime exception" of perl version 5.005_03
4274              
4275             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4276 0           return 'Elatin6::glob("' . $1 . '")';
4277             }
4278              
4279             # __DATA__
4280 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4281              
4282             # __END__
4283 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4284              
4285             # \cD Control-D
4286              
4287             # P.68 2.6.8. Other Literal Tokens
4288             # in Chapter 2: Bits and Pieces
4289             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4290              
4291             # P.76 Other Literal Tokens
4292             # in Chapter 2: Bits and Pieces
4293             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4294              
4295 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4296              
4297             # \cZ Control-Z
4298 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4299              
4300             # any operator before div
4301             elsif (/\G (
4302             -- | \+\+ |
4303             [\)\}\]]
4304              
4305 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4306              
4307             # yada-yada or triple-dot operator
4308             elsif (/\G (
4309             \.\.\.
4310              
4311 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4312              
4313             # any operator before m//
4314              
4315             # //, //= (defined-or)
4316              
4317             # P.164 Logical Operators
4318             # in Chapter 10: More Control Structures
4319             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4320              
4321             # P.119 C-Style Logical (Short-Circuit) Operators
4322             # in Chapter 3: Unary and Binary Operators
4323             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4324              
4325             # (and so on)
4326              
4327             # ~~
4328              
4329             # P.221 The Smart Match Operator
4330             # in Chapter 15: Smart Matching and given-when
4331             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4332              
4333             # P.112 Smartmatch Operator
4334             # in Chapter 3: Unary and Binary Operators
4335             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4336              
4337             # (and so on)
4338              
4339             elsif (/\G ((?>
4340              
4341             !~~ | !~ | != | ! |
4342             %= | % |
4343             &&= | && | &= | &\.= | &\. | & |
4344             -= | -> | - |
4345             :(?>\s*)= |
4346             : |
4347             <<>> |
4348             <<= | <=> | <= | < |
4349             == | => | =~ | = |
4350             >>= | >> | >= | > |
4351             \*\*= | \*\* | \*= | \* |
4352             \+= | \+ |
4353             \.\. | \.= | \. |
4354             \/\/= | \/\/ |
4355             \/= | \/ |
4356             \? |
4357             \\ |
4358             \^= | \^\.= | \^\. | \^ |
4359             \b x= |
4360             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4361             ~~ | ~\. | ~ |
4362             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4363             \b(?: print )\b |
4364              
4365             [,;\(\{\[]
4366              
4367 0           )) /oxgc) { $slash = 'm//'; return $1; }
  0            
4368              
4369             # other any character
4370 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4371              
4372             # system error
4373             else {
4374 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4375             }
4376             }
4377              
4378             # escape Latin-6 string
4379             sub e_string {
4380 0     0 0   my($string) = @_;
4381 0           my $e_string = '';
4382              
4383 0           local $slash = 'm//';
4384              
4385             # P.1024 Appendix W.10 Multibyte Processing
4386             # of ISBN 1-56592-224-7 CJKV Information Processing
4387             # (and so on)
4388              
4389 0           my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4390              
4391             # without { ... }
4392 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4393 0 0         if ($string !~ /<
4394 0           return $string;
4395             }
4396             }
4397              
4398             E_STRING_LOOP:
4399 0           while ($string !~ /\G \z/oxgc) {
4400 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4401             }
4402              
4403             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin6::PREMATCH()]}
4404 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4405 0           $e_string .= q{Elatin6::PREMATCH()};
4406 0           $slash = 'div';
4407             }
4408              
4409             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin6::MATCH()]}
4410             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4411 0           $e_string .= q{Elatin6::MATCH()};
4412 0           $slash = 'div';
4413             }
4414              
4415             # $', ${'} --> $', ${'}
4416             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4417 0           $e_string .= $1;
4418 0           $slash = 'div';
4419             }
4420              
4421             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin6::POSTMATCH()]}
4422             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4423 0           $e_string .= q{Elatin6::POSTMATCH()};
4424 0           $slash = 'div';
4425             }
4426              
4427             # bareword
4428             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4429 0           $e_string .= $1;
4430 0           $slash = 'div';
4431             }
4432              
4433             # $0 --> $0
4434             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4435 0           $e_string .= $1;
4436 0           $slash = 'div';
4437             }
4438             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4439 0           $e_string .= $1;
4440 0           $slash = 'div';
4441             }
4442              
4443             # $$ --> $$
4444             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4445 0           $e_string .= $1;
4446 0           $slash = 'div';
4447             }
4448              
4449             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4450             # $1, $2, $3 --> $1, $2, $3 otherwise
4451             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4452 0           $e_string .= e_capture($1);
4453 0           $slash = 'div';
4454             }
4455             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4456 0           $e_string .= e_capture($1);
4457 0           $slash = 'div';
4458             }
4459              
4460             # $$foo[ ... ] --> $ $foo->[ ... ]
4461             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4462 0           $e_string .= e_capture($1.'->'.$2);
4463 0           $slash = 'div';
4464             }
4465              
4466             # $$foo{ ... } --> $ $foo->{ ... }
4467             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4468 0           $e_string .= e_capture($1.'->'.$2);
4469 0           $slash = 'div';
4470             }
4471              
4472             # $$foo
4473             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4474 0           $e_string .= e_capture($1);
4475 0           $slash = 'div';
4476             }
4477              
4478             # ${ foo }
4479             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4480 0           $e_string .= '${' . $1 . '}';
4481 0           $slash = 'div';
4482             }
4483              
4484             # ${ ... }
4485             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4486 0           $e_string .= e_capture($1);
4487 0           $slash = 'div';
4488             }
4489              
4490             # variable or function
4491             # $ @ % & * $ #
4492             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) {
4493 0           $e_string .= $1;
4494 0           $slash = 'div';
4495             }
4496             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4497             # $ @ # \ ' " / ? ( ) [ ] < >
4498             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4499 0           $e_string .= $1;
4500 0           $slash = 'div';
4501             }
4502              
4503             # subroutines of package Elatin6
4504 0           elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4505 0           elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4506 0           elsif ($string =~ /\G \b Latin6::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4507 0           elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0            
4508 0           elsif ($string =~ /\G \b Latin6::eval \b /oxgc) { $e_string .= 'eval Latin6::escape'; $slash = 'm//'; }
  0            
4509 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4510 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin6::chop'; $slash = 'm//'; }
  0            
4511 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4512 0           elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0            
4513 0           elsif ($string =~ /\G \b Latin6::index \b /oxgc) { $e_string .= 'Latin6::index'; $slash = 'm//'; }
  0            
4514 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin6::index'; $slash = 'm//'; }
  0            
4515 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4516 0           elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0            
4517 0           elsif ($string =~ /\G \b Latin6::rindex \b /oxgc) { $e_string .= 'Latin6::rindex'; $slash = 'm//'; }
  0            
4518 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin6::rindex'; $slash = 'm//'; }
  0            
4519 0           elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::lc'; $slash = 'm//'; }
  0            
4520 0           elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::lcfirst'; $slash = 'm//'; }
  0            
4521 0           elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::uc'; $slash = 'm//'; }
  0            
4522 0           elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::ucfirst'; $slash = 'm//'; }
  0            
4523 0           elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::fc'; $slash = 'm//'; }
  0            
4524              
4525             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4526 0           elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4527 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4528 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4529 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4530 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4531 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4532 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            
4533              
4534 0           elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4535 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4536 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4537 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4538 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4539 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4540 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4541              
4542             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4543 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4544 0           elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4545 0           elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4546 0           elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4547              
4548 0           elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4549 0           elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4550 0           elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::chr'; $slash = 'm//'; }
  0            
4551 0           elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4552 0           elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4553 0           elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin6::glob'; $slash = 'm//'; }
  0            
4554 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin6::lc_'; $slash = 'm//'; }
  0            
4555 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin6::lcfirst_'; $slash = 'm//'; }
  0            
4556 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin6::uc_'; $slash = 'm//'; }
  0            
4557 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin6::ucfirst_'; $slash = 'm//'; }
  0            
4558 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin6::fc_'; $slash = 'm//'; }
  0            
4559 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4560              
4561 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4562 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4563 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin6::chr_'; $slash = 'm//'; }
  0            
4564 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4565 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4566 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin6::glob_'; $slash = 'm//'; }
  0            
4567 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4568 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4569             # split
4570             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4571 0           $slash = 'm//';
4572              
4573 0           my $e = '';
4574 0           while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4575 0           $e .= $1;
4576             }
4577              
4578             # end of split
4579 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin6::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4580              
4581             # split scalar value
4582 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin6::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4583              
4584             # split literal space
4585 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4586 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4587 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4588 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4589 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4590 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4591 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4592 0           elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4593 0           elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4594 0           elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4595 0           elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4596 0           elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4597 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4598 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin6::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4599              
4600             # split qq//
4601             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4602 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0            
  0            
4603             else {
4604 0           while ($string !~ /\G \z/oxgc) {
4605 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4606 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4607 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4608 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4609 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4610 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4611 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0            
4612             }
4613 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4614             }
4615             }
4616              
4617             # split qr//
4618             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4619 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
4620             else {
4621 0           while ($string !~ /\G \z/oxgc) {
4622 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4623 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4624 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4625 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4626 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4627 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            
4628 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4629 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 * *
  0            
4630             }
4631 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4632             }
4633             }
4634              
4635             # split q//
4636             elsif ($string =~ /\G \b (q) \b /oxgc) {
4637 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0            
  0            
4638             else {
4639 0           while ($string !~ /\G \z/oxgc) {
4640 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4641 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4642 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4643 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4644 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4645 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4646 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 * *
  0            
4647             }
4648 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4649             }
4650             }
4651              
4652             # split m//
4653             elsif ($string =~ /\G \b (m) \b /oxgc) {
4654 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 # #
  0            
  0            
4655             else {
4656 0           while ($string !~ /\G \z/oxgc) {
4657 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4658 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            
4659 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            
4660 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            
4661 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            
4662 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            
4663 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4664 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 * *
  0            
4665             }
4666 0           die __FILE__, ": Search pattern not terminated\n";
4667             }
4668             }
4669              
4670             # split ''
4671             elsif ($string =~ /\G (\') /oxgc) {
4672 0           my $q_string = '';
4673 0           while ($string !~ /\G \z/oxgc) {
4674 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4675 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4676 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4677 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4678             }
4679 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4680             }
4681              
4682             # split ""
4683             elsif ($string =~ /\G (\") /oxgc) {
4684 0           my $qq_string = '';
4685 0           while ($string !~ /\G \z/oxgc) {
4686 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4687 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4688 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4689 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4690             }
4691 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4692             }
4693              
4694             # split //
4695             elsif ($string =~ /\G (\/) /oxgc) {
4696 0           my $regexp = '';
4697 0           while ($string !~ /\G \z/oxgc) {
4698 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4699 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4700 0           elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4701 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4702             }
4703 0           die __FILE__, ": Search pattern not terminated\n";
4704             }
4705             }
4706              
4707             # qq//
4708             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4709 0           my $ope = $1;
4710 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4711 0           $e_string .= e_qq($ope,$1,$3,$2);
4712             }
4713             else {
4714 0           my $e = '';
4715 0           while ($string !~ /\G \z/oxgc) {
4716 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4717 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4718 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4719 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4720 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4721 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4722             }
4723 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4724             }
4725             }
4726              
4727             # qx//
4728             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4729 0           my $ope = $1;
4730 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4731 0           $e_string .= e_qq($ope,$1,$3,$2);
4732             }
4733             else {
4734 0           my $e = '';
4735 0           while ($string !~ /\G \z/oxgc) {
4736 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4737 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4738 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4739 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4740 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4741 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4742 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4743             }
4744 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4745             }
4746             }
4747              
4748             # q//
4749             elsif ($string =~ /\G \b (q) \b /oxgc) {
4750 0           my $ope = $1;
4751 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4752 0           $e_string .= e_q($ope,$1,$3,$2);
4753             }
4754             else {
4755 0           my $e = '';
4756 0           while ($string !~ /\G \z/oxgc) {
4757 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4758 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4759 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4760 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4761 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4762 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0            
4763             }
4764 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4765             }
4766             }
4767              
4768             # ''
4769 0           elsif ($string =~ /\G (?
4770              
4771             # ""
4772 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4773              
4774             # ``
4775 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4776              
4777             # <<>> (a safer ARGV)
4778 0           elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4779              
4780             # <<= <=> <= < operator
4781 0           elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4782              
4783             #
4784 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4785              
4786             # --- glob
4787             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4788 0           $e_string .= 'Elatin6::glob("' . $1 . '")';
4789             }
4790              
4791             # << (bit shift) --- not here document
4792 0           elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4793              
4794             # <<'HEREDOC'
4795             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4796 0           $slash = 'm//';
4797 0           my $here_quote = $1;
4798 0           my $delimiter = $2;
4799              
4800             # get here document
4801 0 0         if ($here_script eq '') {
4802 0           $here_script = CORE::substr $_, pos $_;
4803 0           $here_script =~ s/.*?\n//oxm;
4804             }
4805 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4806 0           push @heredoc, $1 . qq{\n$delimiter\n};
4807 0           push @heredoc_delimiter, $delimiter;
4808             }
4809             else {
4810 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4811             }
4812 0           $e_string .= $here_quote;
4813             }
4814              
4815             # <<\HEREDOC
4816             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4817 0           $slash = 'm//';
4818 0           my $here_quote = $1;
4819 0           my $delimiter = $2;
4820              
4821             # get here document
4822 0 0         if ($here_script eq '') {
4823 0           $here_script = CORE::substr $_, pos $_;
4824 0           $here_script =~ s/.*?\n//oxm;
4825             }
4826 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4827 0           push @heredoc, $1 . qq{\n$delimiter\n};
4828 0           push @heredoc_delimiter, $delimiter;
4829             }
4830             else {
4831 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4832             }
4833 0           $e_string .= $here_quote;
4834             }
4835              
4836             # <<"HEREDOC"
4837             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4838 0           $slash = 'm//';
4839 0           my $here_quote = $1;
4840 0           my $delimiter = $2;
4841              
4842             # get here document
4843 0 0         if ($here_script eq '') {
4844 0           $here_script = CORE::substr $_, pos $_;
4845 0           $here_script =~ s/.*?\n//oxm;
4846             }
4847 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4848 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4849 0           push @heredoc_delimiter, $delimiter;
4850             }
4851             else {
4852 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4853             }
4854 0           $e_string .= $here_quote;
4855             }
4856              
4857             # <
4858             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4859 0           $slash = 'm//';
4860 0           my $here_quote = $1;
4861 0           my $delimiter = $2;
4862              
4863             # get here document
4864 0 0         if ($here_script eq '') {
4865 0           $here_script = CORE::substr $_, pos $_;
4866 0           $here_script =~ s/.*?\n//oxm;
4867             }
4868 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4869 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4870 0           push @heredoc_delimiter, $delimiter;
4871             }
4872             else {
4873 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4874             }
4875 0           $e_string .= $here_quote;
4876             }
4877              
4878             # <<`HEREDOC`
4879             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4880 0           $slash = 'm//';
4881 0           my $here_quote = $1;
4882 0           my $delimiter = $2;
4883              
4884             # get here document
4885 0 0         if ($here_script eq '') {
4886 0           $here_script = CORE::substr $_, pos $_;
4887 0           $here_script =~ s/.*?\n//oxm;
4888             }
4889 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4890 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4891 0           push @heredoc_delimiter, $delimiter;
4892             }
4893             else {
4894 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4895             }
4896 0           $e_string .= $here_quote;
4897             }
4898              
4899             # any operator before div
4900             elsif ($string =~ /\G (
4901             -- | \+\+ |
4902             [\)\}\]]
4903              
4904 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4905              
4906             # yada-yada or triple-dot operator
4907             elsif ($string =~ /\G (
4908             \.\.\.
4909              
4910 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4911              
4912             # any operator before m//
4913             elsif ($string =~ /\G ((?>
4914              
4915             !~~ | !~ | != | ! |
4916             %= | % |
4917             &&= | && | &= | &\.= | &\. | & |
4918             -= | -> | - |
4919             :(?>\s*)= |
4920             : |
4921             <<>> |
4922             <<= | <=> | <= | < |
4923             == | => | =~ | = |
4924             >>= | >> | >= | > |
4925             \*\*= | \*\* | \*= | \* |
4926             \+= | \+ |
4927             \.\. | \.= | \. |
4928             \/\/= | \/\/ |
4929             \/= | \/ |
4930             \? |
4931             \\ |
4932             \^= | \^\.= | \^\. | \^ |
4933             \b x= |
4934             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4935             ~~ | ~\. | ~ |
4936             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4937             \b(?: print )\b |
4938              
4939             [,;\(\{\[]
4940              
4941 0           )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4942              
4943             # other any character
4944 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4945              
4946             # system error
4947             else {
4948 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4949             }
4950             }
4951              
4952 0           return $e_string;
4953             }
4954              
4955             #
4956             # character class
4957             #
4958             sub character_class {
4959 0     0 0   my($char,$modifier) = @_;
4960              
4961 0 0         if ($char eq '.') {
4962 0 0         if ($modifier =~ /s/) {
4963 0           return '${Elatin6::dot_s}';
4964             }
4965             else {
4966 0           return '${Elatin6::dot}';
4967             }
4968             }
4969             else {
4970 0           return Elatin6::classic_character_class($char);
4971             }
4972             }
4973              
4974             #
4975             # escape capture ($1, $2, $3, ...)
4976             #
4977             sub e_capture {
4978              
4979 0     0 0   return join '', '${', $_[0], '}';
4980             }
4981              
4982             #
4983             # escape transliteration (tr/// or y///)
4984             #
4985             sub e_tr {
4986 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4987 0           my $e_tr = '';
4988 0   0       $modifier ||= '';
4989              
4990 0           $slash = 'div';
4991              
4992             # quote character class 1
4993 0           $charclass = q_tr($charclass);
4994              
4995             # quote character class 2
4996 0           $charclass2 = q_tr($charclass2);
4997              
4998             # /b /B modifier
4999 0 0         if ($modifier =~ tr/bB//d) {
5000 0 0         if ($variable eq '') {
5001 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
5002             }
5003             else {
5004 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5005             }
5006             }
5007             else {
5008 0 0         if ($variable eq '') {
5009 0           $e_tr = qq{Elatin6::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5010             }
5011             else {
5012 0           $e_tr = qq{Elatin6::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5013             }
5014             }
5015              
5016             # clear tr/// variable
5017 0           $tr_variable = '';
5018 0           $bind_operator = '';
5019              
5020 0           return $e_tr;
5021             }
5022              
5023             #
5024             # quote for escape transliteration (tr/// or y///)
5025             #
5026             sub q_tr {
5027 0     0 0   my($charclass) = @_;
5028              
5029             # quote character class
5030 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5031 0           return e_q('', "'", "'", $charclass); # --> q' '
5032             }
5033             elsif ($charclass !~ /\//oxms) {
5034 0           return e_q('q', '/', '/', $charclass); # --> q/ /
5035             }
5036             elsif ($charclass !~ /\#/oxms) {
5037 0           return e_q('q', '#', '#', $charclass); # --> q# #
5038             }
5039             elsif ($charclass !~ /[\<\>]/oxms) {
5040 0           return e_q('q', '<', '>', $charclass); # --> q< >
5041             }
5042             elsif ($charclass !~ /[\(\)]/oxms) {
5043 0           return e_q('q', '(', ')', $charclass); # --> q( )
5044             }
5045             elsif ($charclass !~ /[\{\}]/oxms) {
5046 0           return e_q('q', '{', '}', $charclass); # --> q{ }
5047             }
5048             else {
5049 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5050 0 0         if ($charclass !~ /\Q$char\E/xms) {
5051 0           return e_q('q', $char, $char, $charclass);
5052             }
5053             }
5054             }
5055              
5056 0           return e_q('q', '{', '}', $charclass);
5057             }
5058              
5059             #
5060             # escape q string (q//, '')
5061             #
5062             sub e_q {
5063 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5064              
5065 0           $slash = 'div';
5066              
5067 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5068             }
5069              
5070             #
5071             # escape qq string (qq//, "", qx//, ``)
5072             #
5073             sub e_qq {
5074 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5075              
5076 0           $slash = 'div';
5077              
5078 0           my $left_e = 0;
5079 0           my $right_e = 0;
5080              
5081             # split regexp
5082 0           my @char = $string =~ /\G((?>
5083             [^\\\$] |
5084             \\x\{ (?>[0-9A-Fa-f]+) \} |
5085             \\o\{ (?>[0-7]+) \} |
5086             \\N\{ (?>[^0-9\}][^\}]*) \} |
5087             \\ $q_char |
5088             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5089             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5090             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5091             \$ (?>\s* [0-9]+) |
5092             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5093             \$ \$ (?![\w\{]) |
5094             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5095             $q_char
5096             ))/oxmsg;
5097              
5098 0           for (my $i=0; $i <= $#char; $i++) {
5099              
5100             # "\L\u" --> "\u\L"
5101 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5102 0           @char[$i,$i+1] = @char[$i+1,$i];
5103             }
5104              
5105             # "\U\l" --> "\l\U"
5106             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5107 0           @char[$i,$i+1] = @char[$i+1,$i];
5108             }
5109              
5110             # octal escape sequence
5111             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5112 0           $char[$i] = Elatin6::octchr($1);
5113             }
5114              
5115             # hexadecimal escape sequence
5116             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5117 0           $char[$i] = Elatin6::hexchr($1);
5118             }
5119              
5120             # \N{CHARNAME} --> N{CHARNAME}
5121             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5122 0           $char[$i] = $1;
5123             }
5124              
5125 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5126             }
5127              
5128             # \F
5129             #
5130             # P.69 Table 2-6. Translation escapes
5131             # in Chapter 2: Bits and Pieces
5132             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5133             # (and so on)
5134              
5135             # \u \l \U \L \F \Q \E
5136 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5137 0 0         if ($right_e < $left_e) {
5138 0           $char[$i] = '\\' . $char[$i];
5139             }
5140             }
5141             elsif ($char[$i] eq '\u') {
5142              
5143             # "STRING @{[ LIST EXPR ]} MORE STRING"
5144              
5145             # P.257 Other Tricks You Can Do with Hard References
5146             # in Chapter 8: References
5147             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5148              
5149             # P.353 Other Tricks You Can Do with Hard References
5150             # in Chapter 8: References
5151             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5152              
5153             # (and so on)
5154              
5155 0           $char[$i] = '@{[Elatin6::ucfirst qq<';
5156 0           $left_e++;
5157             }
5158             elsif ($char[$i] eq '\l') {
5159 0           $char[$i] = '@{[Elatin6::lcfirst qq<';
5160 0           $left_e++;
5161             }
5162             elsif ($char[$i] eq '\U') {
5163 0           $char[$i] = '@{[Elatin6::uc qq<';
5164 0           $left_e++;
5165             }
5166             elsif ($char[$i] eq '\L') {
5167 0           $char[$i] = '@{[Elatin6::lc qq<';
5168 0           $left_e++;
5169             }
5170             elsif ($char[$i] eq '\F') {
5171 0           $char[$i] = '@{[Elatin6::fc qq<';
5172 0           $left_e++;
5173             }
5174             elsif ($char[$i] eq '\Q') {
5175 0           $char[$i] = '@{[CORE::quotemeta qq<';
5176 0           $left_e++;
5177             }
5178             elsif ($char[$i] eq '\E') {
5179 0 0         if ($right_e < $left_e) {
5180 0           $char[$i] = '>]}';
5181 0           $right_e++;
5182             }
5183             else {
5184 0           $char[$i] = '';
5185             }
5186             }
5187             elsif ($char[$i] eq '\Q') {
5188 0           while (1) {
5189 0 0         if (++$i > $#char) {
5190 0           last;
5191             }
5192 0 0         if ($char[$i] eq '\E') {
5193 0           last;
5194             }
5195             }
5196             }
5197             elsif ($char[$i] eq '\E') {
5198             }
5199              
5200             # $0 --> $0
5201             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5202             }
5203             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5204             }
5205              
5206             # $$ --> $$
5207             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5208             }
5209              
5210             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5211             # $1, $2, $3 --> $1, $2, $3 otherwise
5212             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5213 0           $char[$i] = e_capture($1);
5214             }
5215             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5216 0           $char[$i] = e_capture($1);
5217             }
5218              
5219             # $$foo[ ... ] --> $ $foo->[ ... ]
5220             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5221 0           $char[$i] = e_capture($1.'->'.$2);
5222             }
5223              
5224             # $$foo{ ... } --> $ $foo->{ ... }
5225             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5226 0           $char[$i] = e_capture($1.'->'.$2);
5227             }
5228              
5229             # $$foo
5230             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5231 0           $char[$i] = e_capture($1);
5232             }
5233              
5234             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
5235             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5236 0           $char[$i] = '@{[Elatin6::PREMATCH()]}';
5237             }
5238              
5239             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
5240             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5241 0           $char[$i] = '@{[Elatin6::MATCH()]}';
5242             }
5243              
5244             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
5245             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5246 0           $char[$i] = '@{[Elatin6::POSTMATCH()]}';
5247             }
5248              
5249             # ${ foo } --> ${ foo }
5250             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5251             }
5252              
5253             # ${ ... }
5254             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5255 0           $char[$i] = e_capture($1);
5256             }
5257             }
5258              
5259             # return string
5260 0 0         if ($left_e > $right_e) {
5261 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5262             }
5263 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5264             }
5265              
5266             #
5267             # escape qw string (qw//)
5268             #
5269             sub e_qw {
5270 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5271              
5272 0           $slash = 'div';
5273              
5274             # choice again delimiter
5275 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5276 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5277 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5278             }
5279             elsif (not $octet{')'}) {
5280 0           return join '', $ope, '(', $string, ')';
5281             }
5282             elsif (not $octet{'}'}) {
5283 0           return join '', $ope, '{', $string, '}';
5284             }
5285             elsif (not $octet{']'}) {
5286 0           return join '', $ope, '[', $string, ']';
5287             }
5288             elsif (not $octet{'>'}) {
5289 0           return join '', $ope, '<', $string, '>';
5290             }
5291             else {
5292 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5293 0 0         if (not $octet{$char}) {
5294 0           return join '', $ope, $char, $string, $char;
5295             }
5296             }
5297             }
5298              
5299             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5300 0           my @string = CORE::split(/\s+/, $string);
5301 0           for my $string (@string) {
5302 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5303 0           for my $octet (@octet) {
5304 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5305 0           $octet = '\\' . $1;
5306             }
5307             }
5308 0           $string = join '', @octet;
5309             }
5310 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5311             }
5312              
5313             #
5314             # escape here document (<<"HEREDOC", <
5315             #
5316             sub e_heredoc {
5317 0     0 0   my($string) = @_;
5318              
5319 0           $slash = 'm//';
5320              
5321 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5322              
5323 0           my $left_e = 0;
5324 0           my $right_e = 0;
5325              
5326             # split regexp
5327 0           my @char = $string =~ /\G((?>
5328             [^\\\$] |
5329             \\x\{ (?>[0-9A-Fa-f]+) \} |
5330             \\o\{ (?>[0-7]+) \} |
5331             \\N\{ (?>[^0-9\}][^\}]*) \} |
5332             \\ $q_char |
5333             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5334             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5335             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5336             \$ (?>\s* [0-9]+) |
5337             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5338             \$ \$ (?![\w\{]) |
5339             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5340             $q_char
5341             ))/oxmsg;
5342              
5343 0           for (my $i=0; $i <= $#char; $i++) {
5344              
5345             # "\L\u" --> "\u\L"
5346 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5347 0           @char[$i,$i+1] = @char[$i+1,$i];
5348             }
5349              
5350             # "\U\l" --> "\l\U"
5351             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5352 0           @char[$i,$i+1] = @char[$i+1,$i];
5353             }
5354              
5355             # octal escape sequence
5356             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5357 0           $char[$i] = Elatin6::octchr($1);
5358             }
5359              
5360             # hexadecimal escape sequence
5361             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5362 0           $char[$i] = Elatin6::hexchr($1);
5363             }
5364              
5365             # \N{CHARNAME} --> N{CHARNAME}
5366             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5367 0           $char[$i] = $1;
5368             }
5369              
5370 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5371             }
5372              
5373             # \u \l \U \L \F \Q \E
5374 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5375 0 0         if ($right_e < $left_e) {
5376 0           $char[$i] = '\\' . $char[$i];
5377             }
5378             }
5379             elsif ($char[$i] eq '\u') {
5380 0           $char[$i] = '@{[Elatin6::ucfirst qq<';
5381 0           $left_e++;
5382             }
5383             elsif ($char[$i] eq '\l') {
5384 0           $char[$i] = '@{[Elatin6::lcfirst qq<';
5385 0           $left_e++;
5386             }
5387             elsif ($char[$i] eq '\U') {
5388 0           $char[$i] = '@{[Elatin6::uc qq<';
5389 0           $left_e++;
5390             }
5391             elsif ($char[$i] eq '\L') {
5392 0           $char[$i] = '@{[Elatin6::lc qq<';
5393 0           $left_e++;
5394             }
5395             elsif ($char[$i] eq '\F') {
5396 0           $char[$i] = '@{[Elatin6::fc qq<';
5397 0           $left_e++;
5398             }
5399             elsif ($char[$i] eq '\Q') {
5400 0           $char[$i] = '@{[CORE::quotemeta qq<';
5401 0           $left_e++;
5402             }
5403             elsif ($char[$i] eq '\E') {
5404 0 0         if ($right_e < $left_e) {
5405 0           $char[$i] = '>]}';
5406 0           $right_e++;
5407             }
5408             else {
5409 0           $char[$i] = '';
5410             }
5411             }
5412             elsif ($char[$i] eq '\Q') {
5413 0           while (1) {
5414 0 0         if (++$i > $#char) {
5415 0           last;
5416             }
5417 0 0         if ($char[$i] eq '\E') {
5418 0           last;
5419             }
5420             }
5421             }
5422             elsif ($char[$i] eq '\E') {
5423             }
5424              
5425             # $0 --> $0
5426             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5427             }
5428             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5429             }
5430              
5431             # $$ --> $$
5432             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5433             }
5434              
5435             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5436             # $1, $2, $3 --> $1, $2, $3 otherwise
5437             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5438 0           $char[$i] = e_capture($1);
5439             }
5440             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5441 0           $char[$i] = e_capture($1);
5442             }
5443              
5444             # $$foo[ ... ] --> $ $foo->[ ... ]
5445             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5446 0           $char[$i] = e_capture($1.'->'.$2);
5447             }
5448              
5449             # $$foo{ ... } --> $ $foo->{ ... }
5450             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5451 0           $char[$i] = e_capture($1.'->'.$2);
5452             }
5453              
5454             # $$foo
5455             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5456 0           $char[$i] = e_capture($1);
5457             }
5458              
5459             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
5460             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5461 0           $char[$i] = '@{[Elatin6::PREMATCH()]}';
5462             }
5463              
5464             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
5465             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5466 0           $char[$i] = '@{[Elatin6::MATCH()]}';
5467             }
5468              
5469             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
5470             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5471 0           $char[$i] = '@{[Elatin6::POSTMATCH()]}';
5472             }
5473              
5474             # ${ foo } --> ${ foo }
5475             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5476             }
5477              
5478             # ${ ... }
5479             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5480 0           $char[$i] = e_capture($1);
5481             }
5482             }
5483              
5484             # return string
5485 0 0         if ($left_e > $right_e) {
5486 0           return join '', @char, '>]}' x ($left_e - $right_e);
5487             }
5488 0           return join '', @char;
5489             }
5490              
5491             #
5492             # escape regexp (m//, qr//)
5493             #
5494             sub e_qr {
5495 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5496 0   0       $modifier ||= '';
5497              
5498 0           $modifier =~ tr/p//d;
5499 0 0         if ($modifier =~ /([adlu])/oxms) {
5500 0           my $line = 0;
5501 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5502 0 0         if ($filename ne __FILE__) {
5503 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5504 0           last;
5505             }
5506             }
5507 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5508             }
5509              
5510 0           $slash = 'div';
5511              
5512             # literal null string pattern
5513 0 0         if ($string eq '') {
    0          
5514 0           $modifier =~ tr/bB//d;
5515 0           $modifier =~ tr/i//d;
5516 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5517             }
5518              
5519             # /b /B modifier
5520             elsif ($modifier =~ tr/bB//d) {
5521              
5522             # choice again delimiter
5523 0 0         if ($delimiter =~ / [\@:] /oxms) {
5524 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5525 0           my %octet = map {$_ => 1} @char;
  0            
5526 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5527 0           $delimiter = '(';
5528 0           $end_delimiter = ')';
5529             }
5530             elsif (not $octet{'}'}) {
5531 0           $delimiter = '{';
5532 0           $end_delimiter = '}';
5533             }
5534             elsif (not $octet{']'}) {
5535 0           $delimiter = '[';
5536 0           $end_delimiter = ']';
5537             }
5538             elsif (not $octet{'>'}) {
5539 0           $delimiter = '<';
5540 0           $end_delimiter = '>';
5541             }
5542             else {
5543 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5544 0 0         if (not $octet{$char}) {
5545 0           $delimiter = $char;
5546 0           $end_delimiter = $char;
5547 0           last;
5548             }
5549             }
5550             }
5551             }
5552              
5553 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5554 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5555             }
5556             else {
5557 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5558             }
5559             }
5560              
5561 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5562 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5563              
5564             # split regexp
5565 0           my @char = $string =~ /\G((?>
5566             [^\\\$\@\[\(] |
5567             \\x (?>[0-9A-Fa-f]{1,2}) |
5568             \\ (?>[0-7]{2,3}) |
5569             \\c [\x40-\x5F] |
5570             \\x\{ (?>[0-9A-Fa-f]+) \} |
5571             \\o\{ (?>[0-7]+) \} |
5572             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5573             \\ $q_char |
5574             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5575             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5576             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5577             [\$\@] $qq_variable |
5578             \$ (?>\s* [0-9]+) |
5579             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5580             \$ \$ (?![\w\{]) |
5581             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5582             \[\^ |
5583             \[\: (?>[a-z]+) :\] |
5584             \[\:\^ (?>[a-z]+) :\] |
5585             \(\? |
5586             $q_char
5587             ))/oxmsg;
5588              
5589             # choice again delimiter
5590 0 0         if ($delimiter =~ / [\@:] /oxms) {
5591 0           my %octet = map {$_ => 1} @char;
  0            
5592 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5593 0           $delimiter = '(';
5594 0           $end_delimiter = ')';
5595             }
5596             elsif (not $octet{'}'}) {
5597 0           $delimiter = '{';
5598 0           $end_delimiter = '}';
5599             }
5600             elsif (not $octet{']'}) {
5601 0           $delimiter = '[';
5602 0           $end_delimiter = ']';
5603             }
5604             elsif (not $octet{'>'}) {
5605 0           $delimiter = '<';
5606 0           $end_delimiter = '>';
5607             }
5608             else {
5609 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5610 0 0         if (not $octet{$char}) {
5611 0           $delimiter = $char;
5612 0           $end_delimiter = $char;
5613 0           last;
5614             }
5615             }
5616             }
5617             }
5618              
5619 0           my $left_e = 0;
5620 0           my $right_e = 0;
5621 0           for (my $i=0; $i <= $#char; $i++) {
5622              
5623             # "\L\u" --> "\u\L"
5624 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
5625 0           @char[$i,$i+1] = @char[$i+1,$i];
5626             }
5627              
5628             # "\U\l" --> "\l\U"
5629             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5630 0           @char[$i,$i+1] = @char[$i+1,$i];
5631             }
5632              
5633             # octal escape sequence
5634             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5635 0           $char[$i] = Elatin6::octchr($1);
5636             }
5637              
5638             # hexadecimal escape sequence
5639             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5640 0           $char[$i] = Elatin6::hexchr($1);
5641             }
5642              
5643             # \b{...} --> b\{...}
5644             # \B{...} --> B\{...}
5645             # \N{CHARNAME} --> N\{CHARNAME}
5646             # \p{PROPERTY} --> p\{PROPERTY}
5647             # \P{PROPERTY} --> P\{PROPERTY}
5648             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5649 0           $char[$i] = $1 . '\\' . $2;
5650             }
5651              
5652             # \p, \P, \X --> p, P, X
5653             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5654 0           $char[$i] = $1;
5655             }
5656              
5657 0 0 0       if (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          
5658             }
5659              
5660             # join separated multiple-octet
5661 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5662 0 0 0       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)) {
    0 0        
    0 0        
      0        
      0        
      0        
5663 0           $char[$i] .= join '', splice @char, $i+1, 3;
5664             }
5665             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)) {
5666 0           $char[$i] .= join '', splice @char, $i+1, 2;
5667             }
5668             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)) {
5669 0           $char[$i] .= join '', splice @char, $i+1, 1;
5670             }
5671             }
5672              
5673             # open character class [...]
5674             elsif ($char[$i] eq '[') {
5675 0           my $left = $i;
5676              
5677             # [] make die "Unmatched [] in regexp ...\n"
5678             # (and so on)
5679              
5680 0 0         if ($char[$i+1] eq ']') {
5681 0           $i++;
5682             }
5683              
5684 0           while (1) {
5685 0 0         if (++$i > $#char) {
5686 0           die __FILE__, ": Unmatched [] in regexp\n";
5687             }
5688 0 0         if ($char[$i] eq ']') {
5689 0           my $right = $i;
5690              
5691             # [...]
5692 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5693 0           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);
  0            
5694             }
5695             else {
5696 0           splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
5697             }
5698              
5699 0           $i = $left;
5700 0           last;
5701             }
5702             }
5703             }
5704              
5705             # open character class [^...]
5706             elsif ($char[$i] eq '[^') {
5707 0           my $left = $i;
5708              
5709             # [^] make die "Unmatched [] in regexp ...\n"
5710             # (and so on)
5711              
5712 0 0         if ($char[$i+1] eq ']') {
5713 0           $i++;
5714             }
5715              
5716 0           while (1) {
5717 0 0         if (++$i > $#char) {
5718 0           die __FILE__, ": Unmatched [] in regexp\n";
5719             }
5720 0 0         if ($char[$i] eq ']') {
5721 0           my $right = $i;
5722              
5723             # [^...]
5724 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5725 0           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);
  0            
5726             }
5727             else {
5728 0           splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5729             }
5730              
5731 0           $i = $left;
5732 0           last;
5733             }
5734             }
5735             }
5736              
5737             # rewrite character class or escape character
5738             elsif (my $char = character_class($char[$i],$modifier)) {
5739 0           $char[$i] = $char;
5740             }
5741              
5742             # /i modifier
5743             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
5744 0 0         if (CORE::length(Elatin6::fc($char[$i])) == 1) {
5745 0           $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
5746             }
5747             else {
5748 0           $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
5749             }
5750             }
5751              
5752             # \u \l \U \L \F \Q \E
5753             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5754 0 0         if ($right_e < $left_e) {
5755 0           $char[$i] = '\\' . $char[$i];
5756             }
5757             }
5758             elsif ($char[$i] eq '\u') {
5759 0           $char[$i] = '@{[Elatin6::ucfirst qq<';
5760 0           $left_e++;
5761             }
5762             elsif ($char[$i] eq '\l') {
5763 0           $char[$i] = '@{[Elatin6::lcfirst qq<';
5764 0           $left_e++;
5765             }
5766             elsif ($char[$i] eq '\U') {
5767 0           $char[$i] = '@{[Elatin6::uc qq<';
5768 0           $left_e++;
5769             }
5770             elsif ($char[$i] eq '\L') {
5771 0           $char[$i] = '@{[Elatin6::lc qq<';
5772 0           $left_e++;
5773             }
5774             elsif ($char[$i] eq '\F') {
5775 0           $char[$i] = '@{[Elatin6::fc qq<';
5776 0           $left_e++;
5777             }
5778             elsif ($char[$i] eq '\Q') {
5779 0           $char[$i] = '@{[CORE::quotemeta qq<';
5780 0           $left_e++;
5781             }
5782             elsif ($char[$i] eq '\E') {
5783 0 0         if ($right_e < $left_e) {
5784 0           $char[$i] = '>]}';
5785 0           $right_e++;
5786             }
5787             else {
5788 0           $char[$i] = '';
5789             }
5790             }
5791             elsif ($char[$i] eq '\Q') {
5792 0           while (1) {
5793 0 0         if (++$i > $#char) {
5794 0           last;
5795             }
5796 0 0         if ($char[$i] eq '\E') {
5797 0           last;
5798             }
5799             }
5800             }
5801             elsif ($char[$i] eq '\E') {
5802             }
5803              
5804             # $0 --> $0
5805             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5806 0 0         if ($ignorecase) {
5807 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5808             }
5809             }
5810             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5811 0 0         if ($ignorecase) {
5812 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5813             }
5814             }
5815              
5816             # $$ --> $$
5817             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5818             }
5819              
5820             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5821             # $1, $2, $3 --> $1, $2, $3 otherwise
5822             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5823 0           $char[$i] = e_capture($1);
5824 0 0         if ($ignorecase) {
5825 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5826             }
5827             }
5828             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5829 0           $char[$i] = e_capture($1);
5830 0 0         if ($ignorecase) {
5831 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5832             }
5833             }
5834              
5835             # $$foo[ ... ] --> $ $foo->[ ... ]
5836             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5837 0           $char[$i] = e_capture($1.'->'.$2);
5838 0 0         if ($ignorecase) {
5839 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5840             }
5841             }
5842              
5843             # $$foo{ ... } --> $ $foo->{ ... }
5844             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5845 0           $char[$i] = e_capture($1.'->'.$2);
5846 0 0         if ($ignorecase) {
5847 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5848             }
5849             }
5850              
5851             # $$foo
5852             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5853 0           $char[$i] = e_capture($1);
5854 0 0         if ($ignorecase) {
5855 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5856             }
5857             }
5858              
5859             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
5860             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5861 0 0         if ($ignorecase) {
5862 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
5863             }
5864             else {
5865 0           $char[$i] = '@{[Elatin6::PREMATCH()]}';
5866             }
5867             }
5868              
5869             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
5870             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5871 0 0         if ($ignorecase) {
5872 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
5873             }
5874             else {
5875 0           $char[$i] = '@{[Elatin6::MATCH()]}';
5876             }
5877             }
5878              
5879             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
5880             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5881 0 0         if ($ignorecase) {
5882 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
5883             }
5884             else {
5885 0           $char[$i] = '@{[Elatin6::POSTMATCH()]}';
5886             }
5887             }
5888              
5889             # ${ foo }
5890             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5891 0 0         if ($ignorecase) {
5892 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5893             }
5894             }
5895              
5896             # ${ ... }
5897             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5898 0           $char[$i] = e_capture($1);
5899 0 0         if ($ignorecase) {
5900 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5901             }
5902             }
5903              
5904             # $scalar or @array
5905             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5906 0           $char[$i] = e_string($char[$i]);
5907 0 0         if ($ignorecase) {
5908 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
5909             }
5910             }
5911              
5912             # quote character before ? + * {
5913             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5914 0 0 0       if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5915             }
5916             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5917 0           my $char = $char[$i-1];
5918 0 0         if ($char[$i] eq '{') {
5919 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5920             }
5921             else {
5922 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5923             }
5924             }
5925             else {
5926 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5927             }
5928             }
5929             }
5930              
5931             # make regexp string
5932 0           $modifier =~ tr/i//d;
5933 0 0         if ($left_e > $right_e) {
5934 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5935 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5936             }
5937             else {
5938 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5939             }
5940             }
5941 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5942 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5943             }
5944             else {
5945 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5946             }
5947             }
5948              
5949             #
5950             # double quote stuff
5951             #
5952             sub qq_stuff {
5953 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5954              
5955             # scalar variable or array variable
5956 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5957 0           return $stuff;
5958             }
5959              
5960             # quote by delimiter
5961 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5962 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5963 0 0         next if $char eq $delimiter;
5964 0 0         next if $char eq $end_delimiter;
5965 0 0         if (not $octet{$char}) {
5966 0           return join '', 'qq', $char, $stuff, $char;
5967             }
5968             }
5969 0           return join '', 'qq', '<', $stuff, '>';
5970             }
5971              
5972             #
5973             # escape regexp (m'', qr'', and m''b, qr''b)
5974             #
5975             sub e_qr_q {
5976 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5977 0   0       $modifier ||= '';
5978              
5979 0           $modifier =~ tr/p//d;
5980 0 0         if ($modifier =~ /([adlu])/oxms) {
5981 0           my $line = 0;
5982 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5983 0 0         if ($filename ne __FILE__) {
5984 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5985 0           last;
5986             }
5987             }
5988 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5989             }
5990              
5991 0           $slash = 'div';
5992              
5993             # literal null string pattern
5994 0 0         if ($string eq '') {
    0          
5995 0           $modifier =~ tr/bB//d;
5996 0           $modifier =~ tr/i//d;
5997 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5998             }
5999              
6000             # with /b /B modifier
6001             elsif ($modifier =~ tr/bB//d) {
6002 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6003             }
6004              
6005             # without /b /B modifier
6006             else {
6007 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6008             }
6009             }
6010              
6011             #
6012             # escape regexp (m'', qr'')
6013             #
6014             sub e_qr_qt {
6015 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6016              
6017 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6018              
6019             # split regexp
6020 0           my @char = $string =~ /\G((?>
6021             [^\\\[\$\@\/] |
6022             [\x00-\xFF] |
6023             \[\^ |
6024             \[\: (?>[a-z]+) \:\] |
6025             \[\:\^ (?>[a-z]+) \:\] |
6026             [\$\@\/] |
6027             \\ (?:$q_char) |
6028             (?:$q_char)
6029             ))/oxmsg;
6030              
6031             # unescape character
6032 0           for (my $i=0; $i <= $#char; $i++) {
6033 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6034             }
6035              
6036             # open character class [...]
6037 0           elsif ($char[$i] eq '[') {
6038 0           my $left = $i;
6039 0 0         if ($char[$i+1] eq ']') {
6040 0           $i++;
6041             }
6042 0           while (1) {
6043 0 0         if (++$i > $#char) {
6044 0           die __FILE__, ": Unmatched [] in regexp\n";
6045             }
6046 0 0         if ($char[$i] eq ']') {
6047 0           my $right = $i;
6048              
6049             # [...]
6050 0           splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
6051              
6052 0           $i = $left;
6053 0           last;
6054             }
6055             }
6056             }
6057              
6058             # open character class [^...]
6059             elsif ($char[$i] eq '[^') {
6060 0           my $left = $i;
6061 0 0         if ($char[$i+1] eq ']') {
6062 0           $i++;
6063             }
6064 0           while (1) {
6065 0 0         if (++$i > $#char) {
6066 0           die __FILE__, ": Unmatched [] in regexp\n";
6067             }
6068 0 0         if ($char[$i] eq ']') {
6069 0           my $right = $i;
6070              
6071             # [^...]
6072 0           splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6073              
6074 0           $i = $left;
6075 0           last;
6076             }
6077             }
6078             }
6079              
6080             # escape $ @ / and \
6081             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6082 0           $char[$i] = '\\' . $char[$i];
6083             }
6084              
6085             # rewrite character class or escape character
6086             elsif (my $char = character_class($char[$i],$modifier)) {
6087 0           $char[$i] = $char;
6088             }
6089              
6090             # /i modifier
6091             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6092 0 0         if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6093 0           $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6094             }
6095             else {
6096 0           $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
6097             }
6098             }
6099              
6100             # quote character before ? + * {
6101             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6102 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6103             }
6104             else {
6105 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6106             }
6107             }
6108             }
6109              
6110 0           $delimiter = '/';
6111 0           $end_delimiter = '/';
6112              
6113 0           $modifier =~ tr/i//d;
6114 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6115             }
6116              
6117             #
6118             # escape regexp (m''b, qr''b)
6119             #
6120             sub e_qr_qb {
6121 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6122              
6123             # split regexp
6124 0           my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6125              
6126             # unescape character
6127 0           for (my $i=0; $i <= $#char; $i++) {
6128 0 0         if (0) {
    0          
6129             }
6130              
6131             # remain \\
6132 0           elsif ($char[$i] eq '\\\\') {
6133             }
6134              
6135             # escape $ @ / and \
6136             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6137 0           $char[$i] = '\\' . $char[$i];
6138             }
6139             }
6140              
6141 0           $delimiter = '/';
6142 0           $end_delimiter = '/';
6143 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6144             }
6145              
6146             #
6147             # escape regexp (s/here//)
6148             #
6149             sub e_s1 {
6150 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6151 0   0       $modifier ||= '';
6152              
6153 0           $modifier =~ tr/p//d;
6154 0 0         if ($modifier =~ /([adlu])/oxms) {
6155 0           my $line = 0;
6156 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6157 0 0         if ($filename ne __FILE__) {
6158 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6159 0           last;
6160             }
6161             }
6162 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6163             }
6164              
6165 0           $slash = 'div';
6166              
6167             # literal null string pattern
6168 0 0         if ($string eq '') {
    0          
6169 0           $modifier =~ tr/bB//d;
6170 0           $modifier =~ tr/i//d;
6171 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6172             }
6173              
6174             # /b /B modifier
6175             elsif ($modifier =~ tr/bB//d) {
6176              
6177             # choice again delimiter
6178 0 0         if ($delimiter =~ / [\@:] /oxms) {
6179 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6180 0           my %octet = map {$_ => 1} @char;
  0            
6181 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6182 0           $delimiter = '(';
6183 0           $end_delimiter = ')';
6184             }
6185             elsif (not $octet{'}'}) {
6186 0           $delimiter = '{';
6187 0           $end_delimiter = '}';
6188             }
6189             elsif (not $octet{']'}) {
6190 0           $delimiter = '[';
6191 0           $end_delimiter = ']';
6192             }
6193             elsif (not $octet{'>'}) {
6194 0           $delimiter = '<';
6195 0           $end_delimiter = '>';
6196             }
6197             else {
6198 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6199 0 0         if (not $octet{$char}) {
6200 0           $delimiter = $char;
6201 0           $end_delimiter = $char;
6202 0           last;
6203             }
6204             }
6205             }
6206             }
6207              
6208 0           my $prematch = '';
6209 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6210             }
6211              
6212 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6213 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6214              
6215             # split regexp
6216 0           my @char = $string =~ /\G((?>
6217             [^\\\$\@\[\(] |
6218             \\ (?>[1-9][0-9]*) |
6219             \\g (?>\s*) (?>[1-9][0-9]*) |
6220             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6221             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6222             \\x (?>[0-9A-Fa-f]{1,2}) |
6223             \\ (?>[0-7]{2,3}) |
6224             \\c [\x40-\x5F] |
6225             \\x\{ (?>[0-9A-Fa-f]+) \} |
6226             \\o\{ (?>[0-7]+) \} |
6227             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6228             \\ $q_char |
6229             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6230             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6231             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6232             [\$\@] $qq_variable |
6233             \$ (?>\s* [0-9]+) |
6234             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6235             \$ \$ (?![\w\{]) |
6236             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6237             \[\^ |
6238             \[\: (?>[a-z]+) :\] |
6239             \[\:\^ (?>[a-z]+) :\] |
6240             \(\? |
6241             $q_char
6242             ))/oxmsg;
6243              
6244             # choice again delimiter
6245 0 0         if ($delimiter =~ / [\@:] /oxms) {
6246 0           my %octet = map {$_ => 1} @char;
  0            
6247 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6248 0           $delimiter = '(';
6249 0           $end_delimiter = ')';
6250             }
6251             elsif (not $octet{'}'}) {
6252 0           $delimiter = '{';
6253 0           $end_delimiter = '}';
6254             }
6255             elsif (not $octet{']'}) {
6256 0           $delimiter = '[';
6257 0           $end_delimiter = ']';
6258             }
6259             elsif (not $octet{'>'}) {
6260 0           $delimiter = '<';
6261 0           $end_delimiter = '>';
6262             }
6263             else {
6264 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6265 0 0         if (not $octet{$char}) {
6266 0           $delimiter = $char;
6267 0           $end_delimiter = $char;
6268 0           last;
6269             }
6270             }
6271             }
6272             }
6273              
6274             # count '('
6275 0           my $parens = grep { $_ eq '(' } @char;
  0            
6276              
6277 0           my $left_e = 0;
6278 0           my $right_e = 0;
6279 0           for (my $i=0; $i <= $#char; $i++) {
6280              
6281             # "\L\u" --> "\u\L"
6282 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
6283 0           @char[$i,$i+1] = @char[$i+1,$i];
6284             }
6285              
6286             # "\U\l" --> "\l\U"
6287             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6288 0           @char[$i,$i+1] = @char[$i+1,$i];
6289             }
6290              
6291             # octal escape sequence
6292             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6293 0           $char[$i] = Elatin6::octchr($1);
6294             }
6295              
6296             # hexadecimal escape sequence
6297             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6298 0           $char[$i] = Elatin6::hexchr($1);
6299             }
6300              
6301             # \b{...} --> b\{...}
6302             # \B{...} --> B\{...}
6303             # \N{CHARNAME} --> N\{CHARNAME}
6304             # \p{PROPERTY} --> p\{PROPERTY}
6305             # \P{PROPERTY} --> P\{PROPERTY}
6306             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6307 0           $char[$i] = $1 . '\\' . $2;
6308             }
6309              
6310             # \p, \P, \X --> p, P, X
6311             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6312 0           $char[$i] = $1;
6313             }
6314              
6315 0 0 0       if (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          
6316             }
6317              
6318             # join separated multiple-octet
6319 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6320 0 0 0       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)) {
    0 0        
    0 0        
      0        
      0        
      0        
6321 0           $char[$i] .= join '', splice @char, $i+1, 3;
6322             }
6323             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)) {
6324 0           $char[$i] .= join '', splice @char, $i+1, 2;
6325             }
6326             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)) {
6327 0           $char[$i] .= join '', splice @char, $i+1, 1;
6328             }
6329             }
6330              
6331             # open character class [...]
6332             elsif ($char[$i] eq '[') {
6333 0           my $left = $i;
6334 0 0         if ($char[$i+1] eq ']') {
6335 0           $i++;
6336             }
6337 0           while (1) {
6338 0 0         if (++$i > $#char) {
6339 0           die __FILE__, ": Unmatched [] in regexp\n";
6340             }
6341 0 0         if ($char[$i] eq ']') {
6342 0           my $right = $i;
6343              
6344             # [...]
6345 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6346 0           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);
  0            
6347             }
6348             else {
6349 0           splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
6350             }
6351              
6352 0           $i = $left;
6353 0           last;
6354             }
6355             }
6356             }
6357              
6358             # open character class [^...]
6359             elsif ($char[$i] eq '[^') {
6360 0           my $left = $i;
6361 0 0         if ($char[$i+1] eq ']') {
6362 0           $i++;
6363             }
6364 0           while (1) {
6365 0 0         if (++$i > $#char) {
6366 0           die __FILE__, ": Unmatched [] in regexp\n";
6367             }
6368 0 0         if ($char[$i] eq ']') {
6369 0           my $right = $i;
6370              
6371             # [^...]
6372 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6373 0           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);
  0            
6374             }
6375             else {
6376 0           splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6377             }
6378              
6379 0           $i = $left;
6380 0           last;
6381             }
6382             }
6383             }
6384              
6385             # rewrite character class or escape character
6386             elsif (my $char = character_class($char[$i],$modifier)) {
6387 0           $char[$i] = $char;
6388             }
6389              
6390             # /i modifier
6391             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6392 0 0         if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6393 0           $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6394             }
6395             else {
6396 0           $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
6397             }
6398             }
6399              
6400             # \u \l \U \L \F \Q \E
6401             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6402 0 0         if ($right_e < $left_e) {
6403 0           $char[$i] = '\\' . $char[$i];
6404             }
6405             }
6406             elsif ($char[$i] eq '\u') {
6407 0           $char[$i] = '@{[Elatin6::ucfirst qq<';
6408 0           $left_e++;
6409             }
6410             elsif ($char[$i] eq '\l') {
6411 0           $char[$i] = '@{[Elatin6::lcfirst qq<';
6412 0           $left_e++;
6413             }
6414             elsif ($char[$i] eq '\U') {
6415 0           $char[$i] = '@{[Elatin6::uc qq<';
6416 0           $left_e++;
6417             }
6418             elsif ($char[$i] eq '\L') {
6419 0           $char[$i] = '@{[Elatin6::lc qq<';
6420 0           $left_e++;
6421             }
6422             elsif ($char[$i] eq '\F') {
6423 0           $char[$i] = '@{[Elatin6::fc qq<';
6424 0           $left_e++;
6425             }
6426             elsif ($char[$i] eq '\Q') {
6427 0           $char[$i] = '@{[CORE::quotemeta qq<';
6428 0           $left_e++;
6429             }
6430             elsif ($char[$i] eq '\E') {
6431 0 0         if ($right_e < $left_e) {
6432 0           $char[$i] = '>]}';
6433 0           $right_e++;
6434             }
6435             else {
6436 0           $char[$i] = '';
6437             }
6438             }
6439             elsif ($char[$i] eq '\Q') {
6440 0           while (1) {
6441 0 0         if (++$i > $#char) {
6442 0           last;
6443             }
6444 0 0         if ($char[$i] eq '\E') {
6445 0           last;
6446             }
6447             }
6448             }
6449             elsif ($char[$i] eq '\E') {
6450             }
6451              
6452             # \0 --> \0
6453             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6454             }
6455              
6456             # \g{N}, \g{-N}
6457              
6458             # P.108 Using Simple Patterns
6459             # in Chapter 7: In the World of Regular Expressions
6460             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6461              
6462             # P.221 Capturing
6463             # in Chapter 5: Pattern Matching
6464             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6465              
6466             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6467             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6468             }
6469              
6470             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6471             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6472             }
6473              
6474             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6475             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6476             }
6477              
6478             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6479             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6480             }
6481              
6482             # $0 --> $0
6483             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6484 0 0         if ($ignorecase) {
6485 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6486             }
6487             }
6488             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6489 0 0         if ($ignorecase) {
6490 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6491             }
6492             }
6493              
6494             # $$ --> $$
6495             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6496             }
6497              
6498             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6499             # $1, $2, $3 --> $1, $2, $3 otherwise
6500             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6501 0           $char[$i] = e_capture($1);
6502 0 0         if ($ignorecase) {
6503 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6504             }
6505             }
6506             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6507 0           $char[$i] = e_capture($1);
6508 0 0         if ($ignorecase) {
6509 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6510             }
6511             }
6512              
6513             # $$foo[ ... ] --> $ $foo->[ ... ]
6514             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6515 0           $char[$i] = e_capture($1.'->'.$2);
6516 0 0         if ($ignorecase) {
6517 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6518             }
6519             }
6520              
6521             # $$foo{ ... } --> $ $foo->{ ... }
6522             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6523 0           $char[$i] = e_capture($1.'->'.$2);
6524 0 0         if ($ignorecase) {
6525 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6526             }
6527             }
6528              
6529             # $$foo
6530             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6531 0           $char[$i] = e_capture($1);
6532 0 0         if ($ignorecase) {
6533 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6534             }
6535             }
6536              
6537             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
6538             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6539 0 0         if ($ignorecase) {
6540 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
6541             }
6542             else {
6543 0           $char[$i] = '@{[Elatin6::PREMATCH()]}';
6544             }
6545             }
6546              
6547             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
6548             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6549 0 0         if ($ignorecase) {
6550 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
6551             }
6552             else {
6553 0           $char[$i] = '@{[Elatin6::MATCH()]}';
6554             }
6555             }
6556              
6557             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
6558             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6559 0 0         if ($ignorecase) {
6560 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
6561             }
6562             else {
6563 0           $char[$i] = '@{[Elatin6::POSTMATCH()]}';
6564             }
6565             }
6566              
6567             # ${ foo }
6568             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6569 0 0         if ($ignorecase) {
6570 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6571             }
6572             }
6573              
6574             # ${ ... }
6575             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6576 0           $char[$i] = e_capture($1);
6577 0 0         if ($ignorecase) {
6578 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6579             }
6580             }
6581              
6582             # $scalar or @array
6583             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6584 0           $char[$i] = e_string($char[$i]);
6585 0 0         if ($ignorecase) {
6586 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
6587             }
6588             }
6589              
6590             # quote character before ? + * {
6591             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6592 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6593             }
6594             else {
6595 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6596             }
6597             }
6598             }
6599              
6600             # make regexp string
6601 0           my $prematch = '';
6602 0           $modifier =~ tr/i//d;
6603 0 0         if ($left_e > $right_e) {
6604 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6605             }
6606 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6607             }
6608              
6609             #
6610             # escape regexp (s'here'' or s'here''b)
6611             #
6612             sub e_s1_q {
6613 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6614 0   0       $modifier ||= '';
6615              
6616 0           $modifier =~ tr/p//d;
6617 0 0         if ($modifier =~ /([adlu])/oxms) {
6618 0           my $line = 0;
6619 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6620 0 0         if ($filename ne __FILE__) {
6621 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6622 0           last;
6623             }
6624             }
6625 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6626             }
6627              
6628 0           $slash = 'div';
6629              
6630             # literal null string pattern
6631 0 0         if ($string eq '') {
    0          
6632 0           $modifier =~ tr/bB//d;
6633 0           $modifier =~ tr/i//d;
6634 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6635             }
6636              
6637             # with /b /B modifier
6638             elsif ($modifier =~ tr/bB//d) {
6639 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6640             }
6641              
6642             # without /b /B modifier
6643             else {
6644 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6645             }
6646             }
6647              
6648             #
6649             # escape regexp (s'here'')
6650             #
6651             sub e_s1_qt {
6652 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6653              
6654 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6655              
6656             # split regexp
6657 0           my @char = $string =~ /\G((?>
6658             [^\\\[\$\@\/] |
6659             [\x00-\xFF] |
6660             \[\^ |
6661             \[\: (?>[a-z]+) \:\] |
6662             \[\:\^ (?>[a-z]+) \:\] |
6663             [\$\@\/] |
6664             \\ (?:$q_char) |
6665             (?:$q_char)
6666             ))/oxmsg;
6667              
6668             # unescape character
6669 0           for (my $i=0; $i <= $#char; $i++) {
6670 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6671             }
6672              
6673             # open character class [...]
6674 0           elsif ($char[$i] eq '[') {
6675 0           my $left = $i;
6676 0 0         if ($char[$i+1] eq ']') {
6677 0           $i++;
6678             }
6679 0           while (1) {
6680 0 0         if (++$i > $#char) {
6681 0           die __FILE__, ": Unmatched [] in regexp\n";
6682             }
6683 0 0         if ($char[$i] eq ']') {
6684 0           my $right = $i;
6685              
6686             # [...]
6687 0           splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
6688              
6689 0           $i = $left;
6690 0           last;
6691             }
6692             }
6693             }
6694              
6695             # open character class [^...]
6696             elsif ($char[$i] eq '[^') {
6697 0           my $left = $i;
6698 0 0         if ($char[$i+1] eq ']') {
6699 0           $i++;
6700             }
6701 0           while (1) {
6702 0 0         if (++$i > $#char) {
6703 0           die __FILE__, ": Unmatched [] in regexp\n";
6704             }
6705 0 0         if ($char[$i] eq ']') {
6706 0           my $right = $i;
6707              
6708             # [^...]
6709 0           splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6710              
6711 0           $i = $left;
6712 0           last;
6713             }
6714             }
6715             }
6716              
6717             # escape $ @ / and \
6718             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6719 0           $char[$i] = '\\' . $char[$i];
6720             }
6721              
6722             # rewrite character class or escape character
6723             elsif (my $char = character_class($char[$i],$modifier)) {
6724 0           $char[$i] = $char;
6725             }
6726              
6727             # /i modifier
6728             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
6729 0 0         if (CORE::length(Elatin6::fc($char[$i])) == 1) {
6730 0           $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
6731             }
6732             else {
6733 0           $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
6734             }
6735             }
6736              
6737             # quote character before ? + * {
6738             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6739 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6740             }
6741             else {
6742 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6743             }
6744             }
6745             }
6746              
6747 0           $modifier =~ tr/i//d;
6748 0           $delimiter = '/';
6749 0           $end_delimiter = '/';
6750 0           my $prematch = '';
6751 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6752             }
6753              
6754             #
6755             # escape regexp (s'here''b)
6756             #
6757             sub e_s1_qb {
6758 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6759              
6760             # split regexp
6761 0           my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6762              
6763             # unescape character
6764 0           for (my $i=0; $i <= $#char; $i++) {
6765 0 0         if (0) {
    0          
6766             }
6767              
6768             # remain \\
6769 0           elsif ($char[$i] eq '\\\\') {
6770             }
6771              
6772             # escape $ @ / and \
6773             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6774 0           $char[$i] = '\\' . $char[$i];
6775             }
6776             }
6777              
6778 0           $delimiter = '/';
6779 0           $end_delimiter = '/';
6780 0           my $prematch = '';
6781 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6782             }
6783              
6784             #
6785             # escape regexp (s''here')
6786             #
6787             sub e_s2_q {
6788 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6789              
6790 0           $slash = 'div';
6791              
6792 0           my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6793 0           for (my $i=0; $i <= $#char; $i++) {
6794 0 0         if (0) {
    0          
6795             }
6796              
6797             # not escape \\
6798 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6799             }
6800              
6801             # escape $ @ / and \
6802             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6803 0           $char[$i] = '\\' . $char[$i];
6804             }
6805             }
6806              
6807 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6808             }
6809              
6810             #
6811             # escape regexp (s/here/and here/modifier)
6812             #
6813             sub e_sub {
6814 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6815 0   0       $modifier ||= '';
6816              
6817 0           $modifier =~ tr/p//d;
6818 0 0         if ($modifier =~ /([adlu])/oxms) {
6819 0           my $line = 0;
6820 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6821 0 0         if ($filename ne __FILE__) {
6822 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6823 0           last;
6824             }
6825             }
6826 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6827             }
6828              
6829 0 0         if ($variable eq '') {
6830 0           $variable = '$_';
6831 0           $bind_operator = ' =~ ';
6832             }
6833              
6834 0           $slash = 'div';
6835              
6836             # P.128 Start of match (or end of previous match): \G
6837             # P.130 Advanced Use of \G with Perl
6838             # in Chapter 3: Overview of Regular Expression Features and Flavors
6839             # P.312 Iterative Matching: Scalar Context, with /g
6840             # in Chapter 7: Perl
6841             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6842              
6843             # P.181 Where You Left Off: The \G Assertion
6844             # in Chapter 5: Pattern Matching
6845             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6846              
6847             # P.220 Where You Left Off: The \G Assertion
6848             # in Chapter 5: Pattern Matching
6849             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6850              
6851 0           my $e_modifier = $modifier =~ tr/e//d;
6852 0           my $r_modifier = $modifier =~ tr/r//d;
6853              
6854 0           my $my = '';
6855 0 0         if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6856 0           $my = $variable;
6857 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6858 0           $variable =~ s/ = .+ \z//oxms;
6859             }
6860              
6861 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6862 0           $variable_basename =~ s/ \s+ \z//oxms;
6863              
6864             # quote replacement string
6865 0           my $e_replacement = '';
6866 0 0         if ($e_modifier >= 1) {
6867 0           $e_replacement = e_qq('', '', '', $replacement);
6868 0           $e_modifier--;
6869             }
6870             else {
6871 0 0         if ($delimiter2 eq "'") {
6872 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6873             }
6874             else {
6875 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6876             }
6877             }
6878              
6879 0           my $sub = '';
6880              
6881             # with /r
6882 0 0         if ($r_modifier) {
6883 0 0         if (0) {
6884             }
6885              
6886             # s///gr without multibyte anchoring
6887 0           elsif ($modifier =~ /g/oxms) {
6888 0 0         $sub = sprintf(
6889             # 1 2 3 4 5
6890             q,
6891              
6892             $variable, # 1
6893             ($delimiter1 eq "'") ? # 2
6894             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6895             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6896             $s_matched, # 3
6897             $e_replacement, # 4
6898             '$Latin6::re_r=CORE::eval $Latin6::re_r; ' x $e_modifier, # 5
6899             );
6900             }
6901              
6902             # s///r
6903             else {
6904              
6905 0           my $prematch = q{$`};
6906              
6907 0 0         $sub = sprintf(
6908             # 1 2 3 4 5 6 7
6909             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin6::re_r=%s; %s"%s$Latin6::re_r$'" } : %s>,
6910              
6911             $variable, # 1
6912             ($delimiter1 eq "'") ? # 2
6913             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6914             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6915             $s_matched, # 3
6916             $e_replacement, # 4
6917             '$Latin6::re_r=CORE::eval $Latin6::re_r; ' x $e_modifier, # 5
6918             $prematch, # 6
6919             $variable, # 7
6920             );
6921             }
6922              
6923             # $var !~ s///r doesn't make sense
6924 0 0         if ($bind_operator =~ / !~ /oxms) {
6925 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6926             }
6927             }
6928              
6929             # without /r
6930             else {
6931 0 0         if (0) {
6932             }
6933              
6934             # s///g without multibyte anchoring
6935 0           elsif ($modifier =~ /g/oxms) {
6936 0 0         $sub = sprintf(
    0          
6937             # 1 2 3 4 5 6 7 8
6938             q,
6939              
6940             $variable, # 1
6941             ($delimiter1 eq "'") ? # 2
6942             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6943             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6944             $s_matched, # 3
6945             $e_replacement, # 4
6946             '$Latin6::re_r=CORE::eval $Latin6::re_r; ' x $e_modifier, # 5
6947             $variable, # 6
6948             $variable, # 7
6949             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6950             );
6951             }
6952              
6953             # s///
6954             else {
6955              
6956 0           my $prematch = q{$`};
6957              
6958 0 0         $sub = sprintf(
    0          
6959              
6960             ($bind_operator =~ / =~ /oxms) ?
6961              
6962             # 1 2 3 4 5 6 7 8
6963             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin6::re_r=%s; %s%s="%s$Latin6::re_r$'"; 1 } : undef> :
6964              
6965             # 1 2 3 4 5 6 7 8
6966             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin6::re_r=%s; %s%s="%s$Latin6::re_r$'"; undef }>,
6967              
6968             $variable, # 1
6969             $bind_operator, # 2
6970             ($delimiter1 eq "'") ? # 3
6971             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6972             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6973             $s_matched, # 4
6974             $e_replacement, # 5
6975             '$Latin6::re_r=CORE::eval $Latin6::re_r; ' x $e_modifier, # 6
6976             $variable, # 7
6977             $prematch, # 8
6978             );
6979             }
6980             }
6981              
6982             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6983 0 0         if ($my ne '') {
6984 0           $sub = "($my, $sub)[1]";
6985             }
6986              
6987             # clear s/// variable
6988 0           $sub_variable = '';
6989 0           $bind_operator = '';
6990              
6991 0           return $sub;
6992             }
6993              
6994             #
6995             # escape regexp of split qr//
6996             #
6997             sub e_split {
6998 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6999 0   0       $modifier ||= '';
7000              
7001 0           $modifier =~ tr/p//d;
7002 0 0         if ($modifier =~ /([adlu])/oxms) {
7003 0           my $line = 0;
7004 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7005 0 0         if ($filename ne __FILE__) {
7006 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7007 0           last;
7008             }
7009             }
7010 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7011             }
7012              
7013 0           $slash = 'div';
7014              
7015             # /b /B modifier
7016 0 0         if ($modifier =~ tr/bB//d) {
7017 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7018             }
7019              
7020 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7021 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
7022              
7023             # split regexp
7024 0           my @char = $string =~ /\G((?>
7025             [^\\\$\@\[\(] |
7026             \\x (?>[0-9A-Fa-f]{1,2}) |
7027             \\ (?>[0-7]{2,3}) |
7028             \\c [\x40-\x5F] |
7029             \\x\{ (?>[0-9A-Fa-f]+) \} |
7030             \\o\{ (?>[0-7]+) \} |
7031             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7032             \\ $q_char |
7033             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7034             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7035             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7036             [\$\@] $qq_variable |
7037             \$ (?>\s* [0-9]+) |
7038             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7039             \$ \$ (?![\w\{]) |
7040             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7041             \[\^ |
7042             \[\: (?>[a-z]+) :\] |
7043             \[\:\^ (?>[a-z]+) :\] |
7044             \(\? |
7045             $q_char
7046             ))/oxmsg;
7047              
7048 0           my $left_e = 0;
7049 0           my $right_e = 0;
7050 0           for (my $i=0; $i <= $#char; $i++) {
7051              
7052             # "\L\u" --> "\u\L"
7053 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
7054 0           @char[$i,$i+1] = @char[$i+1,$i];
7055             }
7056              
7057             # "\U\l" --> "\l\U"
7058             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7059 0           @char[$i,$i+1] = @char[$i+1,$i];
7060             }
7061              
7062             # octal escape sequence
7063             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7064 0           $char[$i] = Elatin6::octchr($1);
7065             }
7066              
7067             # hexadecimal escape sequence
7068             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7069 0           $char[$i] = Elatin6::hexchr($1);
7070             }
7071              
7072             # \b{...} --> b\{...}
7073             # \B{...} --> B\{...}
7074             # \N{CHARNAME} --> N\{CHARNAME}
7075             # \p{PROPERTY} --> p\{PROPERTY}
7076             # \P{PROPERTY} --> P\{PROPERTY}
7077             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7078 0           $char[$i] = $1 . '\\' . $2;
7079             }
7080              
7081             # \p, \P, \X --> p, P, X
7082             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7083 0           $char[$i] = $1;
7084             }
7085              
7086 0 0 0       if (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          
7087             }
7088              
7089             # join separated multiple-octet
7090 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7091 0 0 0       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)) {
    0 0        
    0 0        
      0        
      0        
      0        
7092 0           $char[$i] .= join '', splice @char, $i+1, 3;
7093             }
7094             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)) {
7095 0           $char[$i] .= join '', splice @char, $i+1, 2;
7096             }
7097             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)) {
7098 0           $char[$i] .= join '', splice @char, $i+1, 1;
7099             }
7100             }
7101              
7102             # open character class [...]
7103             elsif ($char[$i] eq '[') {
7104 0           my $left = $i;
7105 0 0         if ($char[$i+1] eq ']') {
7106 0           $i++;
7107             }
7108 0           while (1) {
7109 0 0         if (++$i > $#char) {
7110 0           die __FILE__, ": Unmatched [] in regexp\n";
7111             }
7112 0 0         if ($char[$i] eq ']') {
7113 0           my $right = $i;
7114              
7115             # [...]
7116 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7117 0           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);
  0            
7118             }
7119             else {
7120 0           splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
7121             }
7122              
7123 0           $i = $left;
7124 0           last;
7125             }
7126             }
7127             }
7128              
7129             # open character class [^...]
7130             elsif ($char[$i] eq '[^') {
7131 0           my $left = $i;
7132 0 0         if ($char[$i+1] eq ']') {
7133 0           $i++;
7134             }
7135 0           while (1) {
7136 0 0         if (++$i > $#char) {
7137 0           die __FILE__, ": Unmatched [] in regexp\n";
7138             }
7139 0 0         if ($char[$i] eq ']') {
7140 0           my $right = $i;
7141              
7142             # [^...]
7143 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7144 0           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);
  0            
7145             }
7146             else {
7147 0           splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7148             }
7149              
7150 0           $i = $left;
7151 0           last;
7152             }
7153             }
7154             }
7155              
7156             # rewrite character class or escape character
7157             elsif (my $char = character_class($char[$i],$modifier)) {
7158 0           $char[$i] = $char;
7159             }
7160              
7161             # P.794 29.2.161. split
7162             # in Chapter 29: Functions
7163             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7164              
7165             # P.951 split
7166             # in Chapter 27: Functions
7167             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7168              
7169             # said "The //m modifier is assumed when you split on the pattern /^/",
7170             # but perl5.008 is not so. Therefore, this software adds //m.
7171             # (and so on)
7172              
7173             # split(m/^/) --> split(m/^/m)
7174             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7175 0           $modifier .= 'm';
7176             }
7177              
7178             # /i modifier
7179             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
7180 0 0         if (CORE::length(Elatin6::fc($char[$i])) == 1) {
7181 0           $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
7182             }
7183             else {
7184 0           $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
7185             }
7186             }
7187              
7188             # \u \l \U \L \F \Q \E
7189             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7190 0 0         if ($right_e < $left_e) {
7191 0           $char[$i] = '\\' . $char[$i];
7192             }
7193             }
7194             elsif ($char[$i] eq '\u') {
7195 0           $char[$i] = '@{[Elatin6::ucfirst qq<';
7196 0           $left_e++;
7197             }
7198             elsif ($char[$i] eq '\l') {
7199 0           $char[$i] = '@{[Elatin6::lcfirst qq<';
7200 0           $left_e++;
7201             }
7202             elsif ($char[$i] eq '\U') {
7203 0           $char[$i] = '@{[Elatin6::uc qq<';
7204 0           $left_e++;
7205             }
7206             elsif ($char[$i] eq '\L') {
7207 0           $char[$i] = '@{[Elatin6::lc qq<';
7208 0           $left_e++;
7209             }
7210             elsif ($char[$i] eq '\F') {
7211 0           $char[$i] = '@{[Elatin6::fc qq<';
7212 0           $left_e++;
7213             }
7214             elsif ($char[$i] eq '\Q') {
7215 0           $char[$i] = '@{[CORE::quotemeta qq<';
7216 0           $left_e++;
7217             }
7218             elsif ($char[$i] eq '\E') {
7219 0 0         if ($right_e < $left_e) {
7220 0           $char[$i] = '>]}';
7221 0           $right_e++;
7222             }
7223             else {
7224 0           $char[$i] = '';
7225             }
7226             }
7227             elsif ($char[$i] eq '\Q') {
7228 0           while (1) {
7229 0 0         if (++$i > $#char) {
7230 0           last;
7231             }
7232 0 0         if ($char[$i] eq '\E') {
7233 0           last;
7234             }
7235             }
7236             }
7237             elsif ($char[$i] eq '\E') {
7238             }
7239              
7240             # $0 --> $0
7241             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7242 0 0         if ($ignorecase) {
7243 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7244             }
7245             }
7246             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7247 0 0         if ($ignorecase) {
7248 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7249             }
7250             }
7251              
7252             # $$ --> $$
7253             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7254             }
7255              
7256             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7257             # $1, $2, $3 --> $1, $2, $3 otherwise
7258             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7259 0           $char[$i] = e_capture($1);
7260 0 0         if ($ignorecase) {
7261 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7262             }
7263             }
7264             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7265 0           $char[$i] = e_capture($1);
7266 0 0         if ($ignorecase) {
7267 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7268             }
7269             }
7270              
7271             # $$foo[ ... ] --> $ $foo->[ ... ]
7272             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7273 0           $char[$i] = e_capture($1.'->'.$2);
7274 0 0         if ($ignorecase) {
7275 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7276             }
7277             }
7278              
7279             # $$foo{ ... } --> $ $foo->{ ... }
7280             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7281 0           $char[$i] = e_capture($1.'->'.$2);
7282 0 0         if ($ignorecase) {
7283 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7284             }
7285             }
7286              
7287             # $$foo
7288             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7289 0           $char[$i] = e_capture($1);
7290 0 0         if ($ignorecase) {
7291 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7292             }
7293             }
7294              
7295             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin6::PREMATCH()
7296             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7297 0 0         if ($ignorecase) {
7298 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::PREMATCH())]}';
7299             }
7300             else {
7301 0           $char[$i] = '@{[Elatin6::PREMATCH()]}';
7302             }
7303             }
7304              
7305             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin6::MATCH()
7306             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7307 0 0         if ($ignorecase) {
7308 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::MATCH())]}';
7309             }
7310             else {
7311 0           $char[$i] = '@{[Elatin6::MATCH()]}';
7312             }
7313             }
7314              
7315             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin6::POSTMATCH()
7316             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7317 0 0         if ($ignorecase) {
7318 0           $char[$i] = '@{[Elatin6::ignorecase(Elatin6::POSTMATCH())]}';
7319             }
7320             else {
7321 0           $char[$i] = '@{[Elatin6::POSTMATCH()]}';
7322             }
7323             }
7324              
7325             # ${ foo }
7326             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7327 0 0         if ($ignorecase) {
7328 0           $char[$i] = '@{[Elatin6::ignorecase(' . $1 . ')]}';
7329             }
7330             }
7331              
7332             # ${ ... }
7333             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7334 0           $char[$i] = e_capture($1);
7335 0 0         if ($ignorecase) {
7336 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7337             }
7338             }
7339              
7340             # $scalar or @array
7341             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7342 0           $char[$i] = e_string($char[$i]);
7343 0 0         if ($ignorecase) {
7344 0           $char[$i] = '@{[Elatin6::ignorecase(' . $char[$i] . ')]}';
7345             }
7346             }
7347              
7348             # quote character before ? + * {
7349             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7350 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7351             }
7352             else {
7353 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7354             }
7355             }
7356             }
7357              
7358             # make regexp string
7359 0           $modifier =~ tr/i//d;
7360 0 0         if ($left_e > $right_e) {
7361 0           return join '', 'Elatin6::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7362             }
7363 0           return join '', 'Elatin6::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7364             }
7365              
7366             #
7367             # escape regexp of split qr''
7368             #
7369             sub e_split_q {
7370 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7371 0   0       $modifier ||= '';
7372              
7373 0           $modifier =~ tr/p//d;
7374 0 0         if ($modifier =~ /([adlu])/oxms) {
7375 0           my $line = 0;
7376 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7377 0 0         if ($filename ne __FILE__) {
7378 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7379 0           last;
7380             }
7381             }
7382 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7383             }
7384              
7385 0           $slash = 'div';
7386              
7387             # /b /B modifier
7388 0 0         if ($modifier =~ tr/bB//d) {
7389 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7390             }
7391              
7392 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7393              
7394             # split regexp
7395 0           my @char = $string =~ /\G((?>
7396             [^\\\[] |
7397             [\x00-\xFF] |
7398             \[\^ |
7399             \[\: (?>[a-z]+) \:\] |
7400             \[\:\^ (?>[a-z]+) \:\] |
7401             \\ (?:$q_char) |
7402             (?:$q_char)
7403             ))/oxmsg;
7404              
7405             # unescape character
7406 0           for (my $i=0; $i <= $#char; $i++) {
7407 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7408             }
7409              
7410             # open character class [...]
7411 0           elsif ($char[$i] eq '[') {
7412 0           my $left = $i;
7413 0 0         if ($char[$i+1] eq ']') {
7414 0           $i++;
7415             }
7416 0           while (1) {
7417 0 0         if (++$i > $#char) {
7418 0           die __FILE__, ": Unmatched [] in regexp\n";
7419             }
7420 0 0         if ($char[$i] eq ']') {
7421 0           my $right = $i;
7422              
7423             # [...]
7424 0           splice @char, $left, $right-$left+1, Elatin6::charlist_qr(@char[$left+1..$right-1], $modifier);
7425              
7426 0           $i = $left;
7427 0           last;
7428             }
7429             }
7430             }
7431              
7432             # open character class [^...]
7433             elsif ($char[$i] eq '[^') {
7434 0           my $left = $i;
7435 0 0         if ($char[$i+1] eq ']') {
7436 0           $i++;
7437             }
7438 0           while (1) {
7439 0 0         if (++$i > $#char) {
7440 0           die __FILE__, ": Unmatched [] in regexp\n";
7441             }
7442 0 0         if ($char[$i] eq ']') {
7443 0           my $right = $i;
7444              
7445             # [^...]
7446 0           splice @char, $left, $right-$left+1, Elatin6::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7447              
7448 0           $i = $left;
7449 0           last;
7450             }
7451             }
7452             }
7453              
7454             # rewrite character class or escape character
7455             elsif (my $char = character_class($char[$i],$modifier)) {
7456 0           $char[$i] = $char;
7457             }
7458              
7459             # split(m/^/) --> split(m/^/m)
7460             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7461 0           $modifier .= 'm';
7462             }
7463              
7464             # /i modifier
7465             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin6::uc($char[$i]) ne Elatin6::fc($char[$i]))) {
7466 0 0         if (CORE::length(Elatin6::fc($char[$i])) == 1) {
7467 0           $char[$i] = '[' . Elatin6::uc($char[$i]) . Elatin6::fc($char[$i]) . ']';
7468             }
7469             else {
7470 0           $char[$i] = '(?:' . Elatin6::uc($char[$i]) . '|' . Elatin6::fc($char[$i]) . ')';
7471             }
7472             }
7473              
7474             # quote character before ? + * {
7475             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7476 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7477             }
7478             else {
7479 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7480             }
7481             }
7482             }
7483              
7484 0           $modifier =~ tr/i//d;
7485 0           return join '', 'Elatin6::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7486             }
7487              
7488             #
7489             # instead of Carp::carp
7490             #
7491             sub carp {
7492 0     0 0   my($package,$filename,$line) = caller(1);
7493 0           print STDERR "@_ at $filename line $line.\n";
7494             }
7495              
7496             #
7497             # instead of Carp::croak
7498             #
7499             sub croak {
7500 0     0 0   my($package,$filename,$line) = caller(1);
7501 0           print STDERR "@_ at $filename line $line.\n";
7502 0           die "\n";
7503             }
7504              
7505             #
7506             # instead of Carp::cluck
7507             #
7508             sub cluck {
7509 0     0 0   my $i = 0;
7510 0           my @cluck = ();
7511 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7512 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7513 0           $i++;
7514             }
7515 0           print STDERR CORE::reverse @cluck;
7516 0           print STDERR "\n";
7517 0           carp @_;
7518             }
7519              
7520             #
7521             # instead of Carp::confess
7522             #
7523             sub confess {
7524 0     0 0   my $i = 0;
7525 0           my @confess = ();
7526 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7527 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7528 0           $i++;
7529             }
7530 0           print STDERR CORE::reverse @confess;
7531 0           print STDERR "\n";
7532 0           croak @_;
7533             }
7534              
7535             1;
7536              
7537             __END__