File Coverage

blib/lib/Elatin8.pm
Criterion Covered Total %
statement 865 3080 28.0
branch 944 2674 35.3
condition 99 373 26.5
subroutine 67 125 53.6
pod 7 74 9.4
total 1982 6326 31.3


line stmt bran cond sub pod time code
1             package Elatin8;
2             ######################################################################
3             #
4             # Elatin8 - Run-time routines for Latin8.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin8/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   3369 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         532  
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   12512 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   999  
  200         295  
  200         27807  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1138 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         289 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         25769 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   12583 CORE::eval q{
  200     200   1026  
  200     78   287  
  200         23030  
  56         5747  
  54         5147  
  47         4315  
  43         4057  
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       98606 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 { };
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65 0         0 BEGIN {
66 200     200   498 my $genpkg = "Symbol::";
67 200         9254 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) && (Elatin8::index($name, '::') == -1) && (Elatin8::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   350 if (CORE::eval { local $@; CORE::require strict }) {
  200         309  
  200         1878  
115 200         21095 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   13952 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   969  
  200         262  
  200         11126  
145 200     200   11438 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   917  
  200         282  
  200         11574  
146 200     200   11031 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   901  
  200         282  
  200         12961  
147              
148             #
149             # Latin-8 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   11884 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   1021  
  200         276  
  200         375597  
157              
158             #
159             # Latin-8 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 Elatin8 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-14 | iec[- ]?8859-14 | latin-?8 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA1" => "\xA2", # LATIN LETTER B WITH DOT ABOVE
183             "\xA4" => "\xA5", # LATIN LETTER C WITH DOT ABOVE
184             "\xA6" => "\xAB", # LATIN LETTER D WITH DOT ABOVE
185             "\xA8" => "\xB8", # LATIN LETTER W WITH GRAVE
186             "\xAA" => "\xBA", # LATIN LETTER W WITH ACUTE
187             "\xAC" => "\xBC", # LATIN LETTER Y WITH GRAVE
188             "\xAF" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
189             "\xB0" => "\xB1", # LATIN LETTER F WITH DOT ABOVE
190             "\xB2" => "\xB3", # LATIN LETTER G WITH DOT ABOVE
191             "\xB4" => "\xB5", # LATIN LETTER M WITH DOT ABOVE
192             "\xB7" => "\xB9", # LATIN LETTER P WITH DOT ABOVE
193             "\xBB" => "\xBF", # LATIN LETTER S WITH DOT ABOVE
194             "\xBD" => "\xBE", # LATIN LETTER W WITH DIAERESIS
195             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
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 C WITH CEDILLA
203             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
204             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
205             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
206             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
207             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
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 W WITH CIRCUMFLEX
212             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
213             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
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 T WITH DOT ABOVE
219             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
220             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
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 Y WITH CIRCUMFLEX
226             );
227              
228             %uc = (%uc,
229             "\xA2" => "\xA1", # LATIN LETTER B WITH DOT ABOVE
230             "\xA5" => "\xA4", # LATIN LETTER C WITH DOT ABOVE
231             "\xAB" => "\xA6", # LATIN LETTER D WITH DOT ABOVE
232             "\xB1" => "\xB0", # LATIN LETTER F WITH DOT ABOVE
233             "\xB3" => "\xB2", # LATIN LETTER G WITH DOT ABOVE
234             "\xB5" => "\xB4", # LATIN LETTER M WITH DOT ABOVE
235             "\xB8" => "\xA8", # LATIN LETTER W WITH GRAVE
236             "\xB9" => "\xB7", # LATIN LETTER P WITH DOT ABOVE
237             "\xBA" => "\xAA", # LATIN LETTER W WITH ACUTE
238             "\xBC" => "\xAC", # LATIN LETTER Y WITH GRAVE
239             "\xBE" => "\xBD", # LATIN LETTER W WITH DIAERESIS
240             "\xBF" => "\xBB", # LATIN LETTER S WITH DOT ABOVE
241             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
242             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
243             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
244             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
245             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
246             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
247             "\xE6" => "\xC6", # LATIN LETTER AE
248             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
249             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
250             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
251             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
252             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
253             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
254             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
255             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
256             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
257             "\xF0" => "\xD0", # LATIN LETTER W WITH CIRCUMFLEX
258             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
259             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
260             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
261             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
262             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
263             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
264             "\xF7" => "\xD7", # LATIN LETTER T WITH DOT ABOVE
265             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
266             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
267             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
268             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
269             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
270             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
271             "\xFE" => "\xDE", # LATIN LETTER Y WITH CIRCUMFLEX
272             "\xFF" => "\xAF", # LATIN LETTER Y WITH DIAERESIS
273             );
274              
275             %fc = (%fc,
276             "\xA1" => "\xA2", # LATIN CAPITAL LETTER B WITH DOT ABOVE --> LATIN SMALL LETTER B WITH DOT ABOVE
277             "\xA4" => "\xA5", # LATIN CAPITAL LETTER C WITH DOT ABOVE --> LATIN SMALL LETTER C WITH DOT ABOVE
278             "\xA6" => "\xAB", # LATIN CAPITAL LETTER D WITH DOT ABOVE --> LATIN SMALL LETTER D WITH DOT ABOVE
279             "\xA8" => "\xB8", # LATIN CAPITAL LETTER W WITH GRAVE --> LATIN SMALL LETTER W WITH GRAVE
280             "\xAA" => "\xBA", # LATIN CAPITAL LETTER W WITH ACUTE --> LATIN SMALL LETTER W WITH ACUTE
281             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Y WITH GRAVE --> LATIN SMALL LETTER Y WITH GRAVE
282             "\xAF" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
283             "\xB0" => "\xB1", # LATIN CAPITAL LETTER F WITH DOT ABOVE --> LATIN SMALL LETTER F WITH DOT ABOVE
284             "\xB2" => "\xB3", # LATIN CAPITAL LETTER G WITH DOT ABOVE --> LATIN SMALL LETTER G WITH DOT ABOVE
285             "\xB4" => "\xB5", # LATIN CAPITAL LETTER M WITH DOT ABOVE --> LATIN SMALL LETTER M WITH DOT ABOVE
286             "\xB7" => "\xB9", # LATIN CAPITAL LETTER P WITH DOT ABOVE --> LATIN SMALL LETTER P WITH DOT ABOVE
287             "\xBB" => "\xBF", # LATIN CAPITAL LETTER S WITH DOT ABOVE --> LATIN SMALL LETTER S WITH DOT ABOVE
288             "\xBD" => "\xBE", # LATIN CAPITAL LETTER W WITH DIAERESIS --> LATIN SMALL LETTER W WITH DIAERESIS
289             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
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 C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
297             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
298             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
299             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
300             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
301             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
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 W WITH CIRCUMFLEX --> LATIN SMALL LETTER W WITH CIRCUMFLEX
306             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
307             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
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 T WITH DOT ABOVE --> LATIN SMALL LETTER T WITH DOT ABOVE
313             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
314             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
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 Y WITH CIRCUMFLEX --> LATIN SMALL LETTER Y WITH CIRCUMFLEX
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 = Elatin8::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 = Elatin8::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 = \&Latin8::ord;
366 0         0 *Char::ord_ = \&Latin8::ord_;
367 0         0 *Char::reverse = \&Latin8::reverse;
368 0         0 *Char::getc = \&Latin8::getc;
369 0         0 *Char::length = \&Latin8::length;
370 0         0 *Char::substr = \&Latin8::substr;
371 0         0 *Char::index = \&Latin8::index;
372 0         0 *Char::rindex = \&Latin8::rindex;
373 0         0 *Char::eval = \&Latin8::eval;
374 0         0 *Char::escape = \&Latin8::escape;
375 0         0 *Char::escape_token = \&Latin8::escape_token;
376 0         0 *Char::escape_script = \&Latin8::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     sub unimport {}
401             sub Elatin8::split(;$$$);
402             sub Elatin8::tr($$$$;$);
403             sub Elatin8::chop(@);
404             sub Elatin8::index($$;$);
405             sub Elatin8::rindex($$;$);
406             sub Elatin8::lcfirst(@);
407             sub Elatin8::lcfirst_();
408             sub Elatin8::lc(@);
409             sub Elatin8::lc_();
410             sub Elatin8::ucfirst(@);
411             sub Elatin8::ucfirst_();
412             sub Elatin8::uc(@);
413             sub Elatin8::uc_();
414             sub Elatin8::fc(@);
415             sub Elatin8::fc_();
416             sub Elatin8::ignorecase;
417             sub Elatin8::classic_character_class;
418             sub Elatin8::capture;
419             sub Elatin8::chr(;$);
420             sub Elatin8::chr_();
421             sub Elatin8::glob($);
422             sub Elatin8::glob_();
423              
424             sub Latin8::ord(;$);
425             sub Latin8::ord_();
426             sub Latin8::reverse(@);
427             sub Latin8::getc(;*@);
428             sub Latin8::length(;$);
429             sub Latin8::substr($$;$$);
430             sub Latin8::index($$;$);
431             sub Latin8::rindex($$;$);
432             sub Latin8::escape(;$);
433              
434             #
435             # Regexp work
436             #
437 200     200   14457 BEGIN { CORE::eval q{ use vars qw(
  200     200   1194  
  200         317  
  200         72342  
438             $Latin8::re_a
439             $Latin8::re_t
440             $Latin8::re_n
441             $Latin8::re_r
442             ) } }
443              
444             #
445             # Character class
446             #
447 200     200   15033 BEGIN { CORE::eval q{ use vars qw(
  200     200   1033  
  200         303  
  200         2486848  
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             ${Elatin8::dot} = qr{(?>[^\x0A])};
478             ${Elatin8::dot_s} = qr{(?>[\x00-\xFF])};
479             ${Elatin8::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             # ${Elatin8::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
485             # ${Elatin8::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
486             ${Elatin8::eS} = qr{(?>[^\s])};
487              
488             ${Elatin8::eW} = qr{(?>[^0-9A-Z_a-z])};
489             ${Elatin8::eH} = qr{(?>[^\x09\x20])};
490             ${Elatin8::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
491             ${Elatin8::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
492             ${Elatin8::eN} = qr{(?>[^\x0A])};
493             ${Elatin8::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
494             ${Elatin8::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
495             ${Elatin8::not_ascii} = qr{(?>[^\x00-\x7F])};
496             ${Elatin8::not_blank} = qr{(?>[^\x09\x20])};
497             ${Elatin8::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
498             ${Elatin8::not_digit} = qr{(?>[^\x30-\x39])};
499             ${Elatin8::not_graph} = qr{(?>[^\x21-\x7F])};
500             ${Elatin8::not_lower} = qr{(?>[^\x61-\x7A])};
501             ${Elatin8::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
502             # ${Elatin8::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
503             ${Elatin8::not_print} = qr{(?>[^\x20-\x7F])};
504             ${Elatin8::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
505             ${Elatin8::not_space} = qr{(?>[^\s\x0B])};
506             ${Elatin8::not_upper} = qr{(?>[^\x41-\x5A])};
507             ${Elatin8::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
508             # ${Elatin8::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
509             ${Elatin8::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
510             ${Elatin8::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
511             ${Elatin8::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
512             ${Elatin8::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
513              
514             # avoid: Name "Elatin8::foo" used only once: possible typo at here.
515             ${Elatin8::dot} = ${Elatin8::dot};
516             ${Elatin8::dot_s} = ${Elatin8::dot_s};
517             ${Elatin8::eD} = ${Elatin8::eD};
518             ${Elatin8::eS} = ${Elatin8::eS};
519             ${Elatin8::eW} = ${Elatin8::eW};
520             ${Elatin8::eH} = ${Elatin8::eH};
521             ${Elatin8::eV} = ${Elatin8::eV};
522             ${Elatin8::eR} = ${Elatin8::eR};
523             ${Elatin8::eN} = ${Elatin8::eN};
524             ${Elatin8::not_alnum} = ${Elatin8::not_alnum};
525             ${Elatin8::not_alpha} = ${Elatin8::not_alpha};
526             ${Elatin8::not_ascii} = ${Elatin8::not_ascii};
527             ${Elatin8::not_blank} = ${Elatin8::not_blank};
528             ${Elatin8::not_cntrl} = ${Elatin8::not_cntrl};
529             ${Elatin8::not_digit} = ${Elatin8::not_digit};
530             ${Elatin8::not_graph} = ${Elatin8::not_graph};
531             ${Elatin8::not_lower} = ${Elatin8::not_lower};
532             ${Elatin8::not_lower_i} = ${Elatin8::not_lower_i};
533             ${Elatin8::not_print} = ${Elatin8::not_print};
534             ${Elatin8::not_punct} = ${Elatin8::not_punct};
535             ${Elatin8::not_space} = ${Elatin8::not_space};
536             ${Elatin8::not_upper} = ${Elatin8::not_upper};
537             ${Elatin8::not_upper_i} = ${Elatin8::not_upper_i};
538             ${Elatin8::not_word} = ${Elatin8::not_word};
539             ${Elatin8::not_xdigit} = ${Elatin8::not_xdigit};
540             ${Elatin8::eb} = ${Elatin8::eb};
541             ${Elatin8::eB} = ${Elatin8::eB};
542              
543             #
544             # Latin-8 split
545             #
546             sub Elatin8::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-8 transliteration (tr///)
756             #
757             sub Elatin8::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-8 chop
847             #
848             sub Elatin8::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-8 index by octet
868             #
869             sub Elatin8::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-8 reverse index
893             #
894             sub Elatin8::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-8 lower case first with parameter
917             #
918             sub Elatin8::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 Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
923             }
924             else {
925 0         0 return Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
926             }
927             }
928             else {
929 0         0 return Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
930             }
931             }
932              
933             #
934             # Latin-8 lower case first without parameter
935             #
936             sub Elatin8::lcfirst_() {
937 0     0 0 0 return Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
938             }
939              
940             #
941             # Latin-8 lower case with parameter
942             #
943             sub Elatin8::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 Elatin8::lc_();
955             }
956             }
957              
958             #
959             # Latin-8 lower case without parameter
960             #
961             sub Elatin8::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-8 upper case first with parameter
968             #
969             sub Elatin8::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 Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
974             }
975             else {
976 0         0 return Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
977             }
978             }
979             else {
980 0         0 return Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
981             }
982             }
983              
984             #
985             # Latin-8 upper case first without parameter
986             #
987             sub Elatin8::ucfirst_() {
988 0     0 0 0 return Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
989             }
990              
991             #
992             # Latin-8 upper case with parameter
993             #
994             sub Elatin8::uc(@) {
995 174 50   174 0 271 if (@_) {
996 174         192 my $s = shift @_;
997 174 50 33     403 if (@_ and wantarray) {
998 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
999             }
1000             else {
1001 174 100       652 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         772  
1002             }
1003             }
1004             else {
1005 0         0 return Elatin8::uc_();
1006             }
1007             }
1008              
1009             #
1010             # Latin-8 upper case without parameter
1011             #
1012             sub Elatin8::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-8 fold case with parameter
1019             #
1020             sub Elatin8::fc(@) {
1021 197 50   197 0 292 if (@_) {
1022 197         208 my $s = shift @_;
1023 197 50 33     458 if (@_ and wantarray) {
1024 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1025             }
1026             else {
1027 197 100       609 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         1566  
1028             }
1029             }
1030             else {
1031 0         0 return Elatin8::fc_();
1032             }
1033             }
1034              
1035             #
1036             # Latin-8 fold case without parameter
1037             #
1038             sub Elatin8::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-8 regexp capture
1045             #
1046             {
1047             sub Elatin8::capture {
1048 0     0 1 0 return $_[0];
1049             }
1050             }
1051              
1052             #
1053             # Latin-8 regexp ignore case modifier
1054             #
1055             sub Elatin8::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 = Elatin8::uc($char[$i]);
1152 0         0 my $fc = Elatin8::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 Elatin8::classic_character_class {
1190 1862     1862 0 1700 my($char) = @_;
1191              
1192             return {
1193             '\D' => '${Elatin8::eD}',
1194             '\S' => '${Elatin8::eS}',
1195             '\W' => '${Elatin8::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' => '${Elatin8::eH}',
1238             '\V' => '${Elatin8::eV}',
1239             '\h' => '[\x09\x20]',
1240             '\v' => '[\x0A\x0B\x0C\x0D]',
1241             '\R' => '${Elatin8::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' => '${Elatin8::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' => '${Elatin8::eb}',
1264              
1265             # \B really means (?:(?<=\w)(?=\w)|(?
1266             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1267             '\B' => '${Elatin8::eB}',
1268              
1269 1862   100     80160 }->{$char} || '';
1270             }
1271              
1272             #
1273             # prepare Latin-8 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-8 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             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 0         0 }->{$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-8 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-8 octet range
1525             #
1526             sub _octets {
1527 182     182   320 my $length = shift @_;
1528              
1529 182 50       415 if ($length == 1) {
1530 182         628 my($a1) = unpack 'C', $_[0];
1531 182         622 my($z1) = unpack 'C', $_[1];
1532              
1533 182 50       496 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 182 50       551 if ($a1 == $z1) {
    50          
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 182         1541 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-8 range regexp
1554             #
1555             sub _range_regexp {
1556 182     182   316 my($length,$first,$last) = @_;
1557              
1558 182         268 my @range_regexp = ();
1559 182 50       580 if (not exists $range_tr{$length}) {
1560 0         0 return @range_regexp;
1561             }
1562              
1563 182         201 my @ranges = @{ $range_tr{$length} };
  182         551  
1564 182         738 while (my @range = splice(@ranges,0,$length)) {
1565 182         304 my $min = '';
1566 182         204 my $max = '';
1567 182         498 for (my $i=0; $i < $length; $i++) {
1568 182         905 $min .= pack 'C', $range[$i][0];
1569 182         605 $max .= pack 'C', $range[$i][-1];
1570             }
1571              
1572             # min___max
1573             # FIRST_____________LAST
1574             # (nothing)
1575              
1576 182 50 33     2666 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    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 182         527 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 182         439 return @range_regexp;
1637             }
1638              
1639             #
1640             # Latin-8 open character list for qr and not qr
1641             #
1642             sub _charlist {
1643              
1644 358     358   639 my $modifier = pop @_;
1645 358         808 my @char = @_;
1646              
1647 358 100       949 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1648              
1649             # unescape character
1650 358         1185 for (my $i=0; $i <= $#char; $i++) {
1651              
1652             # escape - to ...
1653 1125 100 100     11424 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1654 206 100 100     1127 if ((0 < $i) and ($i < $#char)) {
1655 182         487 $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 22         141 $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             $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' => '${Elatin8::eD}',
1714             '\S' => '${Elatin8::eS}',
1715             '\W' => '${Elatin8::eW}',
1716              
1717             '\H' => '${Elatin8::eH}',
1718             '\V' => '${Elatin8::eV}',
1719             '\h' => '[\x09\x20]',
1720             '\v' => '[\x0A\x0B\x0C\x0D]',
1721             '\R' => '${Elatin8::eR}',
1722              
1723 25         445 }->{$1};
1724             }
1725              
1726             # POSIX-style character classes
1727             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1728             $char[$i] = {
1729              
1730             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1731             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1732             '[:^lower:]' => '${Elatin8::not_lower_i}',
1733             '[:^upper:]' => '${Elatin8::not_upper_i}',
1734              
1735 8         71 }->{$1};
1736             }
1737             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1738             $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:]' => '${Elatin8::not_alnum}',
1769             '[:^alpha:]' => '${Elatin8::not_alpha}',
1770             '[:^ascii:]' => '${Elatin8::not_ascii}',
1771             '[:^blank:]' => '${Elatin8::not_blank}',
1772             '[:^cntrl:]' => '${Elatin8::not_cntrl}',
1773             '[:^digit:]' => '${Elatin8::not_digit}',
1774             '[:^graph:]' => '${Elatin8::not_graph}',
1775             '[:^lower:]' => '${Elatin8::not_lower}',
1776             '[:^print:]' => '${Elatin8::not_print}',
1777             '[:^punct:]' => '${Elatin8::not_punct}',
1778             '[:^space:]' => '${Elatin8::not_space}',
1779             '[:^upper:]' => '${Elatin8::not_upper}',
1780             '[:^word:]' => '${Elatin8::not_word}',
1781             '[:^xdigit:]' => '${Elatin8::not_xdigit}',
1782              
1783 70         1545 }->{$1};
1784             }
1785             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1786 7         40 $char[$i] = $1;
1787             }
1788             }
1789              
1790             # open character list
1791 358         680 my @singleoctet = ();
1792 358         496 my @multipleoctet = ();
1793 358         1097 for (my $i=0; $i <= $#char; ) {
1794              
1795             # escaped -
1796 943 100 100     5345 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1797 182         234 $i += 1;
1798 182         366 next;
1799             }
1800              
1801             # make range regexp
1802             elsif ($char[$i] eq '...') {
1803              
1804             # range error
1805 182 50       1153 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
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 182 50       511 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 182         698 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1816 182         279 my @regexp = ();
1817              
1818             # is first and last
1819 182 50 33     1001 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1820 182         624 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 182 50       477 if ($length == 1) {
1843 182         432 push @singleoctet, @regexp;
1844             }
1845             else {
1846 0         0 push @multipleoctet, @regexp;
1847             }
1848             }
1849              
1850 182         470 $i += 2;
1851             }
1852              
1853             # with /i modifier
1854             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1855 493 100       657 if ($modifier =~ /i/oxms) {
1856 24         64 my $uc = Elatin8::uc($char[$i]);
1857 24         63 my $fc = Elatin8::fc($char[$i]);
1858 24 100       54 if ($uc ne $fc) {
1859 12 50       31 if (CORE::length($fc) == 1) {
1860 12         26 push @singleoctet, $uc, $fc;
1861             }
1862             else {
1863 0         0 push @singleoctet, $uc;
1864 0         0 push @multipleoctet, $fc;
1865             }
1866             }
1867             else {
1868 12         27 push @singleoctet, $char[$i];
1869             }
1870             }
1871             else {
1872 469         581 push @singleoctet, $char[$i];
1873             }
1874 493         757 $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 2         6 push @singleoctet, $char[$i];
1888 2         6 $i += 1;
1889             }
1890              
1891             # single character of multiple-octet code
1892             else {
1893 84         149 push @multipleoctet, $char[$i];
1894 84         176 $i += 1;
1895             }
1896             }
1897              
1898             # quote metachar
1899 358         804 for (@singleoctet) {
1900 689 50       3847 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1901 0         0 $_ = '-';
1902             }
1903             elsif (/\A \n \z/oxms) {
1904 8         16 $_ = '\n';
1905             }
1906             elsif (/\A \r \z/oxms) {
1907 8         17 $_ = '\r';
1908             }
1909             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1910 60         233 $_ = sprintf('\x%02X', CORE::ord $1);
1911             }
1912             elsif (/\A [\x00-\xFF] \z/oxms) {
1913 429         533 $_ = quotemeta $_;
1914             }
1915             }
1916              
1917             # return character list
1918 358         1193 return \@singleoctet, \@multipleoctet;
1919             }
1920              
1921             #
1922             # Latin-8 octal escape sequence
1923             #
1924             sub octchr {
1925 5     5 0 11 my($octdigit) = @_;
1926              
1927 5         8 my @binary = ();
1928 5         18 for my $octal (split(//,$octdigit)) {
1929             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 50         147 }->{$octal};
1939             }
1940 5         27 my $binary = join '', @binary;
1941              
1942             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 5         59 }->{CORE::length($binary) % 8};
1954              
1955 5         20 return $octchr;
1956             }
1957              
1958             #
1959             # Latin-8 hexadecimal escape sequence
1960             #
1961             sub hexchr {
1962 5     5 0 10 my($hexdigit) = @_;
1963              
1964             my $hexchr = {
1965             1 => pack('H*', "0$hexdigit"),
1966             0 => pack('H*', "$hexdigit"),
1967              
1968 5         49 }->{CORE::length($_[0]) % 2};
1969              
1970 5         15 return $hexchr;
1971             }
1972              
1973             #
1974             # Latin-8 open character list for qr
1975             #
1976             sub charlist_qr {
1977              
1978 314     314 0 634 my $modifier = pop @_;
1979 314         806 my @char = @_;
1980              
1981 314         1034 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1982 314         753 my @singleoctet = @$singleoctet;
1983 314         487 my @multipleoctet = @$multipleoctet;
1984              
1985             # return character list
1986 314 100       805 if (scalar(@singleoctet) >= 1) {
1987              
1988             # with /i modifier
1989 236 100       605 if ($modifier =~ m/i/oxms) {
1990 22         45 my %singleoctet_ignorecase = ();
1991 22         50 for (@singleoctet) {
1992 46   100     296 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1993 46         194 for my $ord (hex($1) .. hex($2)) {
1994 66         206 my $char = CORE::chr($ord);
1995 66         133 my $uc = Elatin8::uc($char);
1996 66         144 my $fc = Elatin8::fc($char);
1997 66 100       462 if ($uc eq $fc) {
1998 12         156 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1999             }
2000             else {
2001 54 50       98 if (CORE::length($fc) == 1) {
2002 54         161 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2003 54         299 $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 46 50       124 if ($_ ne '') {
2013 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2014             }
2015             }
2016 22         34 my $i = 0;
2017 22         43 my @singleoctet_ignorecase = ();
2018 22         56 for my $ord (0 .. 255) {
2019 5632 100       6276 if (exists $singleoctet_ignorecase{$ord}) {
2020 96         91 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         265  
2021             }
2022             else {
2023 5536         4596 $i++;
2024             }
2025             }
2026 22         64 @singleoctet = ();
2027 22         87 for my $range (@singleoctet_ignorecase) {
2028 3648 100       6469 if (ref $range) {
2029 56 100       41 if (scalar(@{$range}) == 1) {
  56 50       146  
2030 36         34 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         160  
2031             }
2032 20         47 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 20         23 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         37  
  20         244  
2037             }
2038             }
2039             }
2040             }
2041              
2042 236         375 my $not_anchor = '';
2043              
2044 236         837 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2045             }
2046 314 100       703 if (scalar(@multipleoctet) >= 2) {
2047 6         31 return '(?:' . join('|', @multipleoctet) . ')';
2048             }
2049             else {
2050 308         1431 return $multipleoctet[0];
2051             }
2052             }
2053              
2054             #
2055             # Latin-8 open character list for not qr
2056             #
2057             sub charlist_not_qr {
2058              
2059 44     44 0 110 my $modifier = pop @_;
2060 44         133 my @char = @_;
2061              
2062 44         147 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2063 44         131 my @singleoctet = @$singleoctet;
2064 44         199 my @multipleoctet = @$multipleoctet;
2065              
2066             # with /i modifier
2067 44 100       204 if ($modifier =~ m/i/oxms) {
2068 10         18 my %singleoctet_ignorecase = ();
2069 10         16 for (@singleoctet) {
2070 10   66     59 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2071 10         44 for my $ord (hex($1) .. hex($2)) {
2072 30         40 my $char = CORE::chr($ord);
2073 30         42 my $uc = Elatin8::uc($char);
2074 30         47 my $fc = Elatin8::fc($char);
2075 30 50       52 if ($uc eq $fc) {
2076 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2077             }
2078             else {
2079 30 50       44 if (CORE::length($fc) == 1) {
2080 30         76 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2081 30         116 $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 10 50       24 if ($_ ne '') {
2091 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2092             }
2093             }
2094 10         16 my $i = 0;
2095 10         13 my @singleoctet_ignorecase = ();
2096 10         19 for my $ord (0 .. 255) {
2097 2560 100       2438 if (exists $singleoctet_ignorecase{$ord}) {
2098 60         36 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         112  
2099             }
2100             else {
2101 2500         1753 $i++;
2102             }
2103             }
2104 10         24 @singleoctet = ();
2105 10         30 for my $range (@singleoctet_ignorecase) {
2106 960 100       1624 if (ref $range) {
2107 20 50       13 if (scalar(@{$range}) == 1) {
  20 50       38  
2108 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2109             }
2110 20         31 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 20         18 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         25  
  20         122  
2115             }
2116             }
2117             }
2118             }
2119              
2120             # return character list
2121 44 50       132 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 44 50       241 if (scalar(@singleoctet) >= 1) {
2135              
2136             # any character other than single octet character class
2137 44         368 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 400     400   1015 my(undef,$file) = @_;
2152 400         1897 $file =~ s#\A (\s) #./$1#oxms;
2153 400   33     32236 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   825 $| = 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         1853 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         372 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         17592618  
2257             }
2258              
2259             #
2260             # Latin-8 order to character (with parameter)
2261             #
2262             sub Elatin8::chr(;$) {
2263              
2264 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2265              
2266 0 0       0 if ($c == 0x00) {
2267 0         0 return "\x00";
2268             }
2269             else {
2270 0         0 my @chr = ();
2271 0         0 while ($c > 0) {
2272 0         0 unshift @chr, ($c % 0x100);
2273 0         0 $c = int($c / 0x100);
2274             }
2275 0         0 return pack 'C*', @chr;
2276             }
2277             }
2278              
2279             #
2280             # Latin-8 order to character (without parameter)
2281             #
2282             sub Elatin8::chr_() {
2283              
2284 0     0 0 0 my $c = $_;
2285              
2286 0 0       0 if ($c == 0x00) {
2287 0         0 return "\x00";
2288             }
2289             else {
2290 0         0 my @chr = ();
2291 0         0 while ($c > 0) {
2292 0         0 unshift @chr, ($c % 0x100);
2293 0         0 $c = int($c / 0x100);
2294             }
2295 0         0 return pack 'C*', @chr;
2296             }
2297             }
2298              
2299             #
2300             # Latin-8 path globbing (with parameter)
2301             #
2302             sub Elatin8::glob($) {
2303              
2304 0 0   0 0 0 if (wantarray) {
2305 0         0 my @glob = _DOS_like_glob(@_);
2306 0         0 for my $glob (@glob) {
2307 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2308             }
2309 0         0 return @glob;
2310             }
2311             else {
2312 0         0 my $glob = _DOS_like_glob(@_);
2313 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2314 0         0 return $glob;
2315             }
2316             }
2317              
2318             #
2319             # Latin-8 path globbing (without parameter)
2320             #
2321             sub Elatin8::glob_() {
2322              
2323 0 0   0 0 0 if (wantarray) {
2324 0         0 my @glob = _DOS_like_glob();
2325 0         0 for my $glob (@glob) {
2326 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2327             }
2328 0         0 return @glob;
2329             }
2330             else {
2331 0         0 my $glob = _DOS_like_glob();
2332 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2333 0         0 return $glob;
2334             }
2335             }
2336              
2337             #
2338             # Latin-8 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   0 my($expr,$cxix) = @_;
2349              
2350             # glob without args defaults to $_
2351 0 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       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2363 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2364 0         0 { my_home_MSWin32() }oxmse;
2365             }
2366              
2367             # UNIX-like system
2368             else {
2369 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2370 0 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       0 $cxix = '_G_' if not defined $cxix;
2375 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2376              
2377             # if we're just beginning, do it all first
2378 0 0       0 if ($iter{$cxix} == 0) {
2379 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2380             }
2381              
2382             # chuck it all out, quick or slow
2383 0 0       0 if (wantarray) {
2384 0         0 delete $iter{$cxix};
2385 0         0 return @{delete $entries{$cxix}};
  0         0  
2386             }
2387             else {
2388 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2389 0         0 return shift @{$entries{$cxix}};
  0         0  
2390             }
2391             else {
2392             # return undef for EOL
2393 0         0 delete $iter{$cxix};
2394 0         0 delete $entries{$cxix};
2395 0         0 return undef;
2396             }
2397             }
2398             }
2399              
2400             #
2401             # Latin-8 path globbing subroutine
2402             #
2403             sub _do_glob {
2404              
2405 0     0   0 my($cond,@expr) = @_;
2406 0         0 my @glob = ();
2407 0         0 my $fix_drive_relative_paths = 0;
2408              
2409             OUTER:
2410 0         0 for my $expr (@expr) {
2411 0 0       0 next OUTER if not defined $expr;
2412 0 0       0 next OUTER if $expr eq '';
2413              
2414 0         0 my @matched = ();
2415 0         0 my @globdir = ();
2416 0         0 my $head = '.';
2417 0         0 my $pathsep = '/';
2418 0         0 my $tail;
2419              
2420             # if argument is within quotes strip em and do no globbing
2421 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2422 0         0 $expr = $1;
2423 0 0       0 if ($cond eq 'd') {
2424 0 0       0 if (-d $expr) {
2425 0         0 push @glob, $expr;
2426             }
2427             }
2428             else {
2429 0 0       0 if (-e $expr) {
2430 0         0 push @glob, $expr;
2431             }
2432             }
2433 0         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       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2439 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2440 0         0 $fix_drive_relative_paths = 1;
2441             }
2442             }
2443              
2444 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2445 0 0       0 if ($tail eq '') {
2446 0         0 push @glob, $expr;
2447 0         0 next OUTER;
2448             }
2449 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2450 0 0       0 if (@globdir = _do_glob('d', $head)) {
2451 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2452 0         0 next OUTER;
2453             }
2454             }
2455 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2456 0         0 $head .= $pathsep;
2457             }
2458 0         0 $expr = $tail;
2459             }
2460              
2461             # If file component has no wildcards, we can avoid opendir
2462 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2463 0 0       0 if ($head eq '.') {
2464 0         0 $head = '';
2465             }
2466 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2467 0         0 $head .= $pathsep;
2468             }
2469 0         0 $head .= $expr;
2470 0 0       0 if ($cond eq 'd') {
2471 0 0       0 if (-d $head) {
2472 0         0 push @glob, $head;
2473             }
2474             }
2475             else {
2476 0 0       0 if (-e $head) {
2477 0         0 push @glob, $head;
2478             }
2479             }
2480 0         0 next OUTER;
2481             }
2482 0 0       0 opendir(*DIR, $head) or next OUTER;
2483 0         0 my @leaf = readdir DIR;
2484 0         0 closedir DIR;
2485              
2486 0 0       0 if ($head eq '.') {
2487 0         0 $head = '';
2488             }
2489 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2490 0         0 $head .= $pathsep;
2491             }
2492              
2493 0         0 my $pattern = '';
2494 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2495 0         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       0 if ($char eq '*') {
    0          
    0          
2503 0         0 $pattern .= "(?:$your_char)*",
2504             }
2505             elsif ($char eq '?') {
2506 0         0 $pattern .= "(?:$your_char)?", # DOS style
2507             # $pattern .= "(?:$your_char)", # UNIX style
2508             }
2509             elsif ((my $fc = Elatin8::fc($char)) ne $char) {
2510 0         0 $pattern .= $fc;
2511             }
2512             else {
2513 0         0 $pattern .= quotemeta $char;
2514             }
2515             }
2516 0     0   0 my $matchsub = sub { Elatin8::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2517              
2518             # if ($@) {
2519             # print STDERR "$0: $@\n";
2520             # next OUTER;
2521             # }
2522              
2523             INNER:
2524 0         0 for my $leaf (@leaf) {
2525 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2526 0         0 next INNER;
2527             }
2528 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2529 0         0 next INNER;
2530             }
2531              
2532 0 0       0 if (&$matchsub($leaf)) {
2533 0         0 push @matched, "$head$leaf";
2534 0         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     0 if (Elatin8::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             Elatin8::index($pattern,'\\.') != -1 # pattern has a dot.
2543             ) {
2544 0 0       0 if (&$matchsub("$leaf.")) {
2545 0         0 push @matched, "$head$leaf";
2546 0         0 next INNER;
2547             }
2548             }
2549             }
2550 0 0       0 if (@matched) {
2551 0         0 push @glob, @matched;
2552             }
2553             }
2554 0 0       0 if ($fix_drive_relative_paths) {
2555 0         0 for my $glob (@glob) {
2556 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2557             }
2558             }
2559 0         0 return @glob;
2560             }
2561              
2562             #
2563             # Latin-8 parse line
2564             #
2565             sub _parse_line {
2566              
2567 0     0   0 my($line) = @_;
2568              
2569 0         0 $line .= ' ';
2570 0         0 my @piece = ();
2571 0         0 while ($line =~ /
2572             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2573             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2574             /oxmsg
2575             ) {
2576 0 0       0 push @piece, defined($1) ? $1 : $2;
2577             }
2578 0         0 return @piece;
2579             }
2580              
2581             #
2582             # Latin-8 parse path
2583             #
2584             sub _parse_path {
2585              
2586 0     0   0 my($path,$pathsep) = @_;
2587              
2588 0         0 $path .= '/';
2589 0         0 my @subpath = ();
2590 0         0 while ($path =~ /
2591             ((?: [^\/\\] )+?) [\/\\]
2592             /oxmsg
2593             ) {
2594 0         0 push @subpath, $1;
2595             }
2596              
2597 0         0 my $tail = pop @subpath;
2598 0         0 my $head = join $pathsep, @subpath;
2599 0         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 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2611 0         0 return $ENV{'HOME'};
2612             }
2613              
2614             # Do we have a user profile?
2615             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2616 0         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         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2622             }
2623              
2624 0         0 return undef;
2625             }
2626              
2627             #
2628             # via File::HomeDir::Unix 1.00
2629             #
2630             sub my_home {
2631 0     0 0 0 my $home;
2632              
2633 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2634 0         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         0 $home = $ENV{'LOGDIR'};
2641             }
2642              
2643             ### More-desperate methods
2644              
2645             # Light desperation on any (Unixish) platform
2646             else {
2647 0         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     0 if (defined $home and ! -d($home)) {
2653 0         0 $home = undef;
2654             }
2655 0         0 return $home;
2656             }
2657              
2658             #
2659             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2660             #
2661             sub Elatin8::PREMATCH {
2662 0     0 0 0 return $`;
2663             }
2664              
2665             #
2666             # ${^MATCH}, $MATCH, $& the string that matched
2667             #
2668             sub Elatin8::MATCH {
2669 0     0 0 0 return $&;
2670             }
2671              
2672             #
2673             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2674             #
2675             sub Elatin8::POSTMATCH {
2676 0     0 0 0 return $';
2677             }
2678              
2679             #
2680             # Latin-8 character to order (with parameter)
2681             #
2682             sub Latin8::ord(;$) {
2683              
2684 0 0   0 1 0 local $_ = shift if @_;
2685              
2686 0 0       0 if (/\A ($q_char) /oxms) {
2687 0         0 my @ord = unpack 'C*', $1;
2688 0         0 my $ord = 0;
2689 0         0 while (my $o = shift @ord) {
2690 0         0 $ord = $ord * 0x100 + $o;
2691             }
2692 0         0 return $ord;
2693             }
2694             else {
2695 0         0 return CORE::ord $_;
2696             }
2697             }
2698              
2699             #
2700             # Latin-8 character to order (without parameter)
2701             #
2702             sub Latin8::ord_() {
2703              
2704 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2705 0         0 my @ord = unpack 'C*', $1;
2706 0         0 my $ord = 0;
2707 0         0 while (my $o = shift @ord) {
2708 0         0 $ord = $ord * 0x100 + $o;
2709             }
2710 0         0 return $ord;
2711             }
2712             else {
2713 0         0 return CORE::ord $_;
2714             }
2715             }
2716              
2717             #
2718             # Latin-8 reverse
2719             #
2720             sub Latin8::reverse(@) {
2721              
2722 0 0   0 0 0 if (wantarray) {
2723 0         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         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2733             }
2734             }
2735              
2736             #
2737             # Latin-8 getc (with parameter, without parameter)
2738             #
2739             sub Latin8::getc(;*@) {
2740              
2741 0     0 0 0 my($package) = caller;
2742 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2743 0 0 0     0 croak 'Too many arguments for Latin8::getc' if @_ and not wantarray;
2744              
2745 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2746 0         0 my $getc = '';
2747 0         0 for my $length ($length[0] .. $length[-1]) {
2748 0         0 $getc .= CORE::getc($fh);
2749 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2750 0 0       0 if ($getc =~ /\A ${Elatin8::dot_s} \z/oxms) {
2751 0 0       0 return wantarray ? ($getc,@_) : $getc;
2752             }
2753             }
2754             }
2755 0 0       0 return wantarray ? ($getc,@_) : $getc;
2756             }
2757              
2758             #
2759             # Latin-8 length by character
2760             #
2761             sub Latin8::length(;$) {
2762              
2763 0 0   0 1 0 local $_ = shift if @_;
2764              
2765 0         0 local @_ = /\G ($q_char) /oxmsg;
2766 0         0 return scalar @_;
2767             }
2768              
2769             #
2770             # Latin-8 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 117580 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         0  
  0         0  
  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 Latin8::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-8 index by character
2862             #
2863             sub Latin8::index($$;$) {
2864              
2865 0     0 1 0 my $index;
2866 0 0       0 if (@_ == 3) {
2867 0         0 $index = Elatin8::index($_[0], $_[1], CORE::length(Latin8::substr($_[0], 0, $_[2])));
2868             }
2869             else {
2870 0         0 $index = Elatin8::index($_[0], $_[1]);
2871             }
2872              
2873 0 0       0 if ($index == -1) {
2874 0         0 return -1;
2875             }
2876             else {
2877 0         0 return Latin8::length(CORE::substr $_[0], 0, $index);
2878             }
2879             }
2880              
2881             #
2882             # Latin-8 rindex by character
2883             #
2884             sub Latin8::rindex($$;$) {
2885              
2886 0     0 1 0 my $rindex;
2887 0 0       0 if (@_ == 3) {
2888 0         0 $rindex = Elatin8::rindex($_[0], $_[1], CORE::length(Latin8::substr($_[0], 0, $_[2])));
2889             }
2890             else {
2891 0         0 $rindex = Elatin8::rindex($_[0], $_[1]);
2892             }
2893              
2894 0 0       0 if ($rindex == -1) {
2895 0         0 return -1;
2896             }
2897             else {
2898 0         0 return Latin8::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   15970 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1684  
  200         369  
  200         13745  
2905              
2906             # ord() to ord() or Latin8::ord()
2907 200     200   11618 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1024  
  200         370  
  200         10670  
2908              
2909             # ord to ord or Latin8::ord_
2910 200     200   12701 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   1000  
  200         320  
  200         10293  
2911              
2912             # reverse to reverse or Latin8::reverse
2913 200     200   11288 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   922  
  200         353  
  200         10865  
2914              
2915             # getc to getc or Latin8::getc
2916 200     200   10630 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   938  
  200         330  
  200         11253  
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   11896 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   991  
  200         371  
  200         8714055  
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 | Latin8::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-8 script
3031             #
3032             sub Latin8::escape(;$) {
3033 200 50   200 0 668 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 200         355 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 200         366 my $e_script = '';
3061 200         914 while (not /\G \z/oxgc) { # member
3062 72114         92549 $e_script .= Latin8::escape_token();
3063             }
3064              
3065 200         2265 return $e_script;
3066             }
3067              
3068             #
3069             # escape Latin-8 token of script
3070             #
3071             sub Latin8::escape_token {
3072              
3073             # \n output here document
3074              
3075 72114     72114 0 60801 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 72114 100 100     3987889 if (/\G ( \n ) /oxgc) { # another member (and so on)
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3095 12097         10445 my $heredoc = '';
3096 12097 100       21625 if (scalar(@heredoc_delimiter) >= 1) {
3097 150         157 $slash = 'm//';
3098              
3099 150         284 $heredoc = join '', @heredoc;
3100 150         240 @heredoc = ();
3101              
3102             # skip here document
3103 150         241 for my $heredoc_delimiter (@heredoc_delimiter) {
3104 150         1073 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3105             }
3106 150         226 @heredoc_delimiter = ();
3107              
3108 150         184 $here_script = '';
3109             }
3110 12097         35034 return "\n" . $heredoc;
3111             }
3112              
3113             # ignore space, comment
3114 17382         50728 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 1373         1861 $slash = 'm//';
3130 1373         4445 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 85         184 my $e_string = e_string($1);
3150              
3151 85 50       1964 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3152 0         0 $tr_variable = $e_string . e_string($1);
3153 0         0 $bind_operator = $2;
3154 0         0 $slash = 'm//';
3155 0         0 return '';
3156             }
3157             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3158 0         0 $sub_variable = $e_string . e_string($1);
3159 0         0 $bind_operator = $2;
3160 0         0 $slash = 'm//';
3161 0         0 return '';
3162             }
3163             else {
3164 85         113 $slash = 'div';
3165 85         289 return $e_string;
3166             }
3167             }
3168              
3169             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
3170             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3171 4         8 $slash = 'div';
3172 4         16 return q{Elatin8::PREMATCH()};
3173             }
3174              
3175             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
3176             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3177 28         50 $slash = 'div';
3178 28         88 return q{Elatin8::MATCH()};
3179             }
3180              
3181             # $', ${'} --> $', ${'}
3182             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3183 1         2 $slash = 'div';
3184 1         6 return $1;
3185             }
3186              
3187             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
3188             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3189 3         7 $slash = 'div';
3190 3         14 return q{Elatin8::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 1604         3166 my $scalar = e_string($1);
3199              
3200 1604 100       6828 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3201 1         4 $tr_variable = $scalar;
3202 1         5 $bind_operator = $1;
3203 1         3 $slash = 'm//';
3204 1         6 return '';
3205             }
3206             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3207 61         110 $sub_variable = $scalar;
3208 61         112 $bind_operator = $1;
3209 61         85 $slash = 'm//';
3210 61         252 return '';
3211             }
3212             else {
3213 1542         1706 $slash = 'div';
3214 1542         4216 return $scalar;
3215             }
3216             }
3217              
3218             # end of statement
3219             elsif (/\G ( [,;] ) /oxgc) {
3220 4592         5150 $slash = 'm//';
3221              
3222             # clear tr/// variable
3223 4592         4593 $tr_variable = '';
3224              
3225             # clear s/// variable
3226 4592         3919 $sub_variable = '';
3227              
3228 4592         3749 $bind_operator = '';
3229              
3230 4592         17130 return $1;
3231             }
3232              
3233             # bareword
3234             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3235 0         0 return $1;
3236             }
3237              
3238             # $0 --> $0
3239             elsif (/\G ( \$ 0 ) /oxmsgc) {
3240 2         6 $slash = 'div';
3241 2         7 return $1;
3242             }
3243             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3244 0         0 $slash = 'div';
3245 0         0 return $1;
3246             }
3247              
3248             # $$ --> $$
3249             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3250 1         2 $slash = 'div';
3251 1         3 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 4         6 $slash = 'div';
3258 4         7 return e_capture($1);
3259             }
3260             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3261 0         0 $slash = 'div';
3262 0         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         0 $slash = 'div';
3268 0         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         0 $slash = 'div';
3274 0         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         0 $slash = 'div';
3280 0         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         0 $slash = 'div';
3286 0         0 return '${' . $1 . '}';
3287             }
3288              
3289             # ${ ... }
3290             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3291 0         0 $slash = 'div';
3292 0         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 42         58 $slash = 'div';
3299 42         138 return $1;
3300             }
3301             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3302             # $ @ # \ ' " / ? ( ) [ ] < >
3303             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3304 60         96 $slash = 'div';
3305 60         225 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         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         0 return 'while ($_ = Elatin8::glob("' . $1 . '"))';
3319             }
3320              
3321             # while (glob)
3322             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3323 0         0 return 'while ($_ = Elatin8::glob_)';
3324             }
3325              
3326             # while (glob(WILDCARD))
3327             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3328 0         0 return 'while ($_ = Elatin8::glob';
3329             }
3330              
3331             # doit if, doit unless, doit while, doit until, doit for, doit when
3332 241         486 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         1016  
3333              
3334             # subroutines of package Elatin8
3335 19         33 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         64  
3336 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3337 13         19 elsif (/\G \b Latin8::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         49  
3338 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3339 114         123 elsif (/\G \b Latin8::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin8::escape'; }
  114         304  
3340 2         5 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         10  
3341 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::chop'; }
  0         0  
3342 2         4 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         4  
3343 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3344 0         0 elsif (/\G \b Latin8::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin8::index'; }
  0         0  
3345 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::index'; }
  0         0  
3346 2         5 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
3347 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3348 0         0 elsif (/\G \b Latin8::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin8::rindex'; }
  0         0  
3349 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::rindex'; }
  0         0  
3350 1         2 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::lc'; }
  1         4  
3351 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::lcfirst'; }
  0         0  
3352 1         1 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::uc'; }
  1         4  
3353 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::ucfirst'; }
  0         0  
3354 6         6 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::fc'; }
  6         18  
3355              
3356             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3357 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3358 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3359 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3360 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3361 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3362 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3363 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3364              
3365 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3366 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3367 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3368 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3369 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3370 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3371 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3372              
3373             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3374 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3375 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3376 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3377 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3378              
3379 2         4 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         7  
3380 2         3 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         7  
3381 36         55 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::chr'; }
  36         116  
3382 2         4 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         6  
3383 8         11 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         20  
3384 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::glob'; }
  0         0  
3385 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::lc_'; }
  0         0  
3386 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::lcfirst_'; }
  0         0  
3387 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::uc_'; }
  0         0  
3388 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::ucfirst_'; }
  0         0  
3389 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::fc_'; }
  0         0  
3390 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3391              
3392 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3393 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3394 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::chr_'; }
  0         0  
3395 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3396 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3397 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::glob_'; }
  0         0  
3398 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3399 8         17 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         27  
3400             # split
3401             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3402 87         164 $slash = 'm//';
3403              
3404 87         125 my $e = '';
3405 87         443 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3406 85         379 $e .= $1;
3407             }
3408              
3409             # end of split
3410 87 100       7715 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin8::split' . $e; }
  2 100       7  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3411              
3412             # split scalar value
3413 1         7 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin8::split' . $e . e_string($1); }
3414              
3415             # split literal space
3416 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin8::split' . $e . qq {qq$1 $2}; }
3417 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3418 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3419 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3420 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3421 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3422 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin8::split' . $e . qq {q$1 $2}; }
3423 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3424 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3425 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3426 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3427 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3428 10         64 elsif (/\G ' [ ] ' /oxgc) { return 'Elatin8::split' . $e . qq {' '}; }
3429 0         0 elsif (/\G " [ ] " /oxgc) { return 'Elatin8::split' . $e . qq {" "}; }
3430              
3431             # split qq//
3432             elsif (/\G \b (qq) \b /oxgc) {
3433 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3434             else {
3435 0         0 while (not /\G \z/oxgc) {
3436 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3437 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3438 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3439 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3440 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3441 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3442 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3443             }
3444 0         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 12 50       492 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3451             else {
3452 12         61 while (not /\G \z/oxgc) {
3453 12 50       3596 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3454 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3455 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3456 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3457 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3458 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3459 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3460 12         83 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3461             }
3462 0         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       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3469             else {
3470 0         0 while (not /\G \z/oxgc) {
3471 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3472 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3473 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3474 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3475 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3476 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3477 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3478             }
3479 0         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 18 50       596 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3486             else {
3487 18         86 while (not /\G \z/oxgc) {
3488 18 50       4403 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3489 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3490 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3491 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3492 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3493 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3494 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3495 18         103 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3496             }
3497 0         0 die __FILE__, ": Search pattern not terminated\n";
3498             }
3499             }
3500              
3501             # split ''
3502             elsif (/\G (\') /oxgc) {
3503 0         0 my $q_string = '';
3504 0         0 while (not /\G \z/oxgc) {
3505 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3506 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3507 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3508 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3509             }
3510 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3511             }
3512              
3513             # split ""
3514             elsif (/\G (\") /oxgc) {
3515 0         0 my $qq_string = '';
3516 0         0 while (not /\G \z/oxgc) {
3517 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3518 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3519 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3520 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3521             }
3522 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3523             }
3524              
3525             # split //
3526             elsif (/\G (\/) /oxgc) {
3527 44         78 my $regexp = '';
3528 44         160 while (not /\G \z/oxgc) {
3529 381 50       1766 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3530 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3531 44         205 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3532 337         743 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3533             }
3534 0         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 3         12 my $ope = $1;
3548              
3549             # $1 $2 $3 $4 $5 $6
3550 3 50       64 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3551 0         0 my @tr = ($tr_variable,$2);
3552 0         0 return e_tr(@tr,'',$4,$6);
3553             }
3554             else {
3555 3         10 my $e = '';
3556 3         14 while (not /\G \z/oxgc) {
3557 3 50       351 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3558             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3559 0         0 my @tr = ($tr_variable,$2);
3560 0         0 while (not /\G \z/oxgc) {
3561 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3562 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3563 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3564 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3565 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3566 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3567             }
3568 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3569             }
3570             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3571 0         0 my @tr = ($tr_variable,$2);
3572 0         0 while (not /\G \z/oxgc) {
3573 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3574 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3575 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3576 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3577 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3578 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3579             }
3580 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3581             }
3582             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3583 0         0 my @tr = ($tr_variable,$2);
3584 0         0 while (not /\G \z/oxgc) {
3585 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3586 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3587 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3588 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3589 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3590 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3591             }
3592 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3593             }
3594             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3595 0         0 my @tr = ($tr_variable,$2);
3596 0         0 while (not /\G \z/oxgc) {
3597 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3598 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3599 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3600 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3601 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3602 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3603             }
3604 0         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 3         20 my @tr = ($tr_variable,$2);
3609 3         16 return e_tr(@tr,'',$4,$6);
3610             }
3611             }
3612 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3613             }
3614             }
3615              
3616             # qq//
3617             elsif (/\G \b (qq) \b /oxgc) {
3618 2130         4152 my $ope = $1;
3619              
3620             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3621 2130 50       3840 if (/\G (\#) /oxgc) { # qq# #
3622 0         0 my $qq_string = '';
3623 0         0 while (not /\G \z/oxgc) {
3624 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3625 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3626 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3627 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3628             }
3629 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3630             }
3631              
3632             else {
3633 2130         2296 my $e = '';
3634 2130         5088 while (not /\G \z/oxgc) {
3635 2130 50       8805 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3636              
3637             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3638             elsif (/\G (\() /oxgc) { # qq ( )
3639 0         0 my $qq_string = '';
3640 0         0 local $nest = 1;
3641 0         0 while (not /\G \z/oxgc) {
3642 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3643 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3644 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3645             elsif (/\G (\)) /oxgc) {
3646 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3647 0         0 else { $qq_string .= $1; }
3648             }
3649 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3650             }
3651 0         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 2100         2281 my $qq_string = '';
3657 2100         2799 local $nest = 1;
3658 2100         4446 while (not /\G \z/oxgc) {
3659 82644 100       286832 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1379  
    100          
    100          
    50          
3660 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3661 1103         1230 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         1939  
3662             elsif (/\G (\}) /oxgc) {
3663 3203 100       4464 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         4367  
3664 1103         2255 else { $qq_string .= $1; }
3665             }
3666 77616         151774 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3667             }
3668 0         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         0 my $qq_string = '';
3674 0         0 local $nest = 1;
3675 0         0 while (not /\G \z/oxgc) {
3676 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3677 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3678 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3679             elsif (/\G (\]) /oxgc) {
3680 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3681 0         0 else { $qq_string .= $1; }
3682             }
3683 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3684             }
3685 0         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 30         40 my $qq_string = '';
3691 30         50 local $nest = 1;
3692 30         99 while (not /\G \z/oxgc) {
3693 1166 100       4518 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       59  
    50          
    100          
    50          
3694 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3695 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3696             elsif (/\G (\>) /oxgc) {
3697 30 50       73 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         96  
3698 0         0 else { $qq_string .= $1; }
3699             }
3700 1114         2219 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3701             }
3702 0         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         0 my $delimiter = $1;
3708 0         0 my $qq_string = '';
3709 0         0 while (not /\G \z/oxgc) {
3710 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3711 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3712 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3713 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3714             }
3715 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3716             }
3717             }
3718 0         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         0 my $ope = $1;
3725 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3726 0         0 return e_qr($ope,$1,$3,$2,$4);
3727             }
3728             else {
3729 0         0 my $e = '';
3730 0         0 while (not /\G \z/oxgc) {
3731 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3732 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3733 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3734 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3735 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3736 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3737 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3738 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3739             }
3740 0         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 16         37 my $ope = $1;
3747 16 50       62 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3748 0         0 return e_qw($ope,$1,$3,$2);
3749             }
3750             else {
3751 16         26 my $e = '';
3752 16         53 while (not /\G \z/oxgc) {
3753 16 50       110 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3754              
3755 16         57 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3756 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3757              
3758 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3759 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3760              
3761 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3762 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3763              
3764 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3765 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3766              
3767 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3768 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3769             }
3770 0         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         0 my $ope = $1;
3777 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3778 0         0 return e_qq($ope,$1,$3,$2);
3779             }
3780             else {
3781 0         0 my $e = '';
3782 0         0 while (not /\G \z/oxgc) {
3783 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3784 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3785 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3786 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3787 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3788 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3789 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3790             }
3791 0         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 245         694 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 245 50       807 if (/\G (\#) /oxgc) { # q# #
3805 0         0 my $q_string = '';
3806 0         0 while (not /\G \z/oxgc) {
3807 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3808 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3809 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3810 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3811             }
3812 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3813             }
3814              
3815             else {
3816 245         458 my $e = '';
3817 245         911 while (not /\G \z/oxgc) {
3818 245 50       1798 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3819              
3820             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3821             elsif (/\G (\() /oxgc) { # q ( )
3822 0         0 my $q_string = '';
3823 0         0 local $nest = 1;
3824 0         0 while (not /\G \z/oxgc) {
3825 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3826 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3827 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3828 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3829             elsif (/\G (\)) /oxgc) {
3830 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3831 0         0 else { $q_string .= $1; }
3832             }
3833 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3834             }
3835 0         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 239         454 my $q_string = '';
3841 239         466 local $nest = 1;
3842 239         886 while (not /\G \z/oxgc) {
3843 3637 50       18519 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3844 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3845 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3846 107         137 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         195  
3847             elsif (/\G (\}) /oxgc) {
3848 346 100       798 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         884  
3849 107         234 else { $q_string .= $1; }
3850             }
3851 3184         6450 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3852             }
3853 0         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         0 my $q_string = '';
3859 0         0 local $nest = 1;
3860 0         0 while (not /\G \z/oxgc) {
3861 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3862 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3863 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3864 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3865             elsif (/\G (\]) /oxgc) {
3866 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3867 0         0 else { $q_string .= $1; }
3868             }
3869 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3870             }
3871 0         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 5         12 my $q_string = '';
3877 5         11 local $nest = 1;
3878 5         72 while (not /\G \z/oxgc) {
3879 88 50       531 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3880 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3881 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3882 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3883             elsif (/\G (\>) /oxgc) {
3884 5 50       15 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         19  
3885 0         0 else { $q_string .= $1; }
3886             }
3887 83         203 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3888             }
3889 0         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 1         2 my $delimiter = $1;
3895 1         2 my $q_string = '';
3896 1         4 while (not /\G \z/oxgc) {
3897 14 50       85 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3898 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3899 1         5 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3900 13         38 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3901             }
3902 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3903             }
3904             }
3905 0         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 209         510 my $ope = $1;
3912 209 50       2197 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3913 0         0 return e_qr($ope,$1,$3,$2,$4);
3914             }
3915             else {
3916 209         354 my $e = '';
3917 209         738 while (not /\G \z/oxgc) {
3918 209 50       14888 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3919 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3920 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3921 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3922 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3923 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3924 10         25 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3925 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3926 199         785 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3927             }
3928 0         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 97         205 my $ope = $1;
3941              
3942             # $1 $2 $3 $4 $5 $6
3943 97 100       2181 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3944 1         4 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3945             }
3946             else {
3947 96         146 my $e = '';
3948 96         306 while (not /\G \z/oxgc) {
3949 96 50       13239 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3950             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3951 0         0 my @s = ($1,$2,$3);
3952 0         0 while (not /\G \z/oxgc) {
3953 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3954             # $1 $2 $3 $4
3955 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964             }
3965 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3966             }
3967             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3968 0         0 my @s = ($1,$2,$3);
3969 0         0 while (not /\G \z/oxgc) {
3970 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3971             # $1 $2 $3 $4
3972 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981             }
3982 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3983             }
3984             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3985 0         0 my @s = ($1,$2,$3);
3986 0         0 while (not /\G \z/oxgc) {
3987 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3988             # $1 $2 $3 $4
3989 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3990 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3991 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3992 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3993 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3994 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3995 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996             }
3997 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3998             }
3999             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
4000 0         0 my @s = ($1,$2,$3);
4001 0         0 while (not /\G \z/oxgc) {
4002 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4003             # $1 $2 $3 $4
4004 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4005 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4006 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4007 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4008 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4009 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4010 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4011 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4012 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4013             }
4014 0         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 21         59 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         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         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 75         307 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4031             }
4032             }
4033 0         0 die __FILE__, ": Substitution pattern not terminated\n";
4034             }
4035             }
4036              
4037             # require ignore module
4038 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4039 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4040 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4041              
4042             # use strict; --> use strict; no strict qw(refs);
4043 36         319 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4044 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4045 0         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 2 50 33     25 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4050 0         0 return "use $1; no strict qw(refs);";
4051             }
4052             else {
4053 2         13 return "use $1;";
4054             }
4055             }
4056             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4057 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4058 0         0 return "use $1; no strict qw(refs);";
4059             }
4060             else {
4061 0         0 return "use $1;";
4062             }
4063             }
4064              
4065             # ignore use module
4066 2         14 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4067 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4068 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4069              
4070             # ignore no module
4071 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4072 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4073 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4074              
4075             # use else
4076 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4077              
4078             # use else
4079 2         7 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4080              
4081             # ''
4082             elsif (/\G (?
4083 841         1357 my $q_string = '';
4084 841         2275 while (not /\G \z/oxgc) {
4085 8209 100       29264 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       11  
    100          
    50          
4086 48         100 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4087 841         2026 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4088 7316         14837 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4089             }
4090 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4091             }
4092              
4093             # ""
4094             elsif (/\G (\") /oxgc) {
4095 1807         2708 my $qq_string = '';
4096 1807         4565 while (not /\G \z/oxgc) {
4097 34624 100       108691 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       191  
    100          
    50          
4098 12         22 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4099 1807         4128 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4100 32738         67207 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4101             }
4102 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4103             }
4104              
4105             # ``
4106             elsif (/\G (\`) /oxgc) {
4107 1         3 my $qx_string = '';
4108 1         7 while (not /\G \z/oxgc) {
4109 19 50       121 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4110 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4111 1         6 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4112 18         50 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4113             }
4114 0         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 452         808 my $regexp = '';
4120 452         1449 while (not /\G \z/oxgc) {
4121 4490 50       17063 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4122 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4123 452         1505 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4124 4038         8440 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4125             }
4126 0         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         0 my $regexp = '';
4132 0         0 while (not /\G \z/oxgc) {
4133 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4134 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4135 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4136 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4137             }
4138 0         0 die __FILE__, ": Search pattern not terminated\n";
4139             }
4140              
4141             # <<>> (a safer ARGV)
4142 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4143              
4144             # << (bit shift) --- not here document
4145 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4146              
4147             # <<'HEREDOC'
4148             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4149 72         91 $slash = 'm//';
4150 72         137 my $here_quote = $1;
4151 72         98 my $delimiter = $2;
4152              
4153             # get here document
4154 72 50       144 if ($here_script eq '') {
4155 72         341 $here_script = CORE::substr $_, pos $_;
4156 72         408 $here_script =~ s/.*?\n//oxm;
4157             }
4158 72 50       578 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4159 72         219 push @heredoc, $1 . qq{\n$delimiter\n};
4160 72         106 push @heredoc_delimiter, $delimiter;
4161             }
4162             else {
4163 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4164             }
4165 72         287 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         0 $slash = 'm//';
4180 0         0 my $here_quote = $1;
4181 0         0 my $delimiter = $2;
4182              
4183             # get here document
4184 0 0       0 if ($here_script eq '') {
4185 0         0 $here_script = CORE::substr $_, pos $_;
4186 0         0 $here_script =~ s/.*?\n//oxm;
4187             }
4188 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4189 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4190 0         0 push @heredoc_delimiter, $delimiter;
4191             }
4192             else {
4193 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4194             }
4195 0         0 return $here_quote;
4196             }
4197              
4198             # <<"HEREDOC"
4199             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4200 36         66 $slash = 'm//';
4201 36         86 my $here_quote = $1;
4202 36         490 my $delimiter = $2;
4203              
4204             # get here document
4205 36 50       99 if ($here_script eq '') {
4206 36         297 $here_script = CORE::substr $_, pos $_;
4207 36         218 $here_script =~ s/.*?\n//oxm;
4208             }
4209 36 50       821 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4210 36         107 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4211 36         156 push @heredoc_delimiter, $delimiter;
4212             }
4213             else {
4214 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4215             }
4216 36         162 return $here_quote;
4217             }
4218              
4219             # <
4220             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4221 42         113 $slash = 'm//';
4222 42         101 my $here_quote = $1;
4223 42         83 my $delimiter = $2;
4224              
4225             # get here document
4226 42 50       125 if ($here_script eq '') {
4227 42         413 $here_script = CORE::substr $_, pos $_;
4228 42         340 $here_script =~ s/.*?\n//oxm;
4229             }
4230 42 50       652 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4231 42         140 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4232 42         93 push @heredoc_delimiter, $delimiter;
4233             }
4234             else {
4235 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4236             }
4237 42         210 return $here_quote;
4238             }
4239              
4240             # <<`HEREDOC`
4241             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4242 0         0 $slash = 'm//';
4243 0         0 my $here_quote = $1;
4244 0         0 my $delimiter = $2;
4245              
4246             # get here document
4247 0 0       0 if ($here_script eq '') {
4248 0         0 $here_script = CORE::substr $_, pos $_;
4249 0         0 $here_script =~ s/.*?\n//oxm;
4250             }
4251 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4252 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4253 0         0 push @heredoc_delimiter, $delimiter;
4254             }
4255             else {
4256 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4257             }
4258 0         0 return $here_quote;
4259             }
4260              
4261             # <<= <=> <= < operator
4262             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4263 11         52 return $1;
4264             }
4265              
4266             #
4267             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4268 0         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         0 return 'Elatin8::glob("' . $1 . '")';
4277             }
4278              
4279             # __DATA__
4280 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4281              
4282             # __END__
4283 200         1404 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         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4296              
4297             # \cZ Control-Z
4298 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4299              
4300             # any operator before div
4301             elsif (/\G (
4302             -- | \+\+ |
4303             [\)\}\]]
4304              
4305 4824         6353 ) /oxgc) { $slash = 'div'; return $1; }
  4824         21187  
4306              
4307             # yada-yada or triple-dot operator
4308             elsif (/\G (
4309             \.\.\.
4310              
4311 7         11 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         26  
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 8515         10592 )) /oxgc) { $slash = 'm//'; return $1; }
  8515         38095  
4368              
4369             # other any character
4370 14740         17051 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14740         65339  
4371              
4372             # system error
4373             else {
4374 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4375             }
4376             }
4377              
4378             # escape Latin-8 string
4379             sub e_string {
4380 1718     1718 0 3236 my($string) = @_;
4381 1718         1888 my $e_string = '';
4382              
4383 1718         2227 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 1718         16372 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4390              
4391             # without { ... }
4392 1718 100 66     7823 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4393 1701 50       3714 if ($string !~ /<
4394 1701         4289 return $string;
4395             }
4396             }
4397              
4398             E_STRING_LOOP:
4399 17         57 while ($string !~ /\G \z/oxgc) {
4400 190 50       12582 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4401             }
4402              
4403             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin8::PREMATCH()]}
4404 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4405 0         0 $e_string .= q{Elatin8::PREMATCH()};
4406 0         0 $slash = 'div';
4407             }
4408              
4409             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin8::MATCH()]}
4410             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4411 0         0 $e_string .= q{Elatin8::MATCH()};
4412 0         0 $slash = 'div';
4413             }
4414              
4415             # $', ${'} --> $', ${'}
4416             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4417 0         0 $e_string .= $1;
4418 0         0 $slash = 'div';
4419             }
4420              
4421             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin8::POSTMATCH()]}
4422             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4423 0         0 $e_string .= q{Elatin8::POSTMATCH()};
4424 0         0 $slash = 'div';
4425             }
4426              
4427             # bareword
4428             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4429 0         0 $e_string .= $1;
4430 0         0 $slash = 'div';
4431             }
4432              
4433             # $0 --> $0
4434             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4435 0         0 $e_string .= $1;
4436 0         0 $slash = 'div';
4437             }
4438             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4439 0         0 $e_string .= $1;
4440 0         0 $slash = 'div';
4441             }
4442              
4443             # $$ --> $$
4444             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4445 0         0 $e_string .= $1;
4446 0         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         0 $e_string .= e_capture($1);
4453 0         0 $slash = 'div';
4454             }
4455             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4456 0         0 $e_string .= e_capture($1);
4457 0         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         0 $e_string .= e_capture($1.'->'.$2);
4463 0         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         0 $e_string .= e_capture($1.'->'.$2);
4469 0         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         0 $e_string .= e_capture($1);
4475 0         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         0 $e_string .= '${' . $1 . '}';
4481 0         0 $slash = 'div';
4482             }
4483              
4484             # ${ ... }
4485             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4486 3         9 $e_string .= e_capture($1);
4487 3         13 $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 7         13 $e_string .= $1;
4494 7         21 $slash = 'div';
4495             }
4496             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4497             # $ @ # \ ' " / ? ( ) [ ] < >
4498             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4499 0         0 $e_string .= $1;
4500 0         0 $slash = 'div';
4501             }
4502              
4503             # subroutines of package Elatin8
4504 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4505 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4506 0         0 elsif ($string =~ /\G \b Latin8::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4507 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4508 0         0 elsif ($string =~ /\G \b Latin8::eval \b /oxgc) { $e_string .= 'eval Latin8::escape'; $slash = 'm//'; }
  0         0  
4509 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4510 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin8::chop'; $slash = 'm//'; }
  0         0  
4511 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4512 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4513 0         0 elsif ($string =~ /\G \b Latin8::index \b /oxgc) { $e_string .= 'Latin8::index'; $slash = 'm//'; }
  0         0  
4514 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin8::index'; $slash = 'm//'; }
  0         0  
4515 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4516 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4517 0         0 elsif ($string =~ /\G \b Latin8::rindex \b /oxgc) { $e_string .= 'Latin8::rindex'; $slash = 'm//'; }
  0         0  
4518 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin8::rindex'; $slash = 'm//'; }
  0         0  
4519 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::lc'; $slash = 'm//'; }
  0         0  
4520 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::lcfirst'; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::uc'; $slash = 'm//'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::ucfirst'; $slash = 'm//'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::fc'; $slash = 'm//'; }
  0         0  
4524              
4525             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4526 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4527 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4528 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4529 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4530 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4531 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4532 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4533              
4534 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4535 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4536 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4537 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4538 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4539 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4540 0         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         0  
4541              
4542             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4543 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4544 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4545 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4546 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4547              
4548 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4549 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4550 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::chr'; $slash = 'm//'; }
  0         0  
4551 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4552 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4553 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin8::glob'; $slash = 'm//'; }
  0         0  
4554 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin8::lc_'; $slash = 'm//'; }
  0         0  
4555 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin8::lcfirst_'; $slash = 'm//'; }
  0         0  
4556 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin8::uc_'; $slash = 'm//'; }
  0         0  
4557 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin8::ucfirst_'; $slash = 'm//'; }
  0         0  
4558 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin8::fc_'; $slash = 'm//'; }
  0         0  
4559 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4560              
4561 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4562 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4563 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin8::chr_'; $slash = 'm//'; }
  0         0  
4564 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4565 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4566 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin8::glob_'; $slash = 'm//'; }
  0         0  
4567 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4568 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4569             # split
4570             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4571 0         0 $slash = 'm//';
4572              
4573 0         0 my $e = '';
4574 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4575 0         0 $e .= $1;
4576             }
4577              
4578             # end of split
4579 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin8::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          
    0          
4580              
4581             # split scalar value
4582 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin8::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4583              
4584             # split literal space
4585 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4586 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4587 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4588 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4589 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4590 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4591 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4592 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4593 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4594 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4595 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4596 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4597 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4598 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin8::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4599              
4600             # split qq//
4601             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4602 0 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  
  0         0  
4603             else {
4604 0         0 while ($string !~ /\G \z/oxgc) {
4605 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4606 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4607 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4608 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4609 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4610 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4611 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0         0  
4612             }
4613 0         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       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  
  0         0  
4620             else {
4621 0         0 while ($string !~ /\G \z/oxgc) {
4622 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4623 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4624 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4625 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4626 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4627 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4628 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0         0  
4629 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0         0  
4630             }
4631 0         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       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  
  0         0  
4638             else {
4639 0         0 while ($string !~ /\G \z/oxgc) {
4640 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4641 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4642 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4643 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4644 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4645 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0         0  
4646 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
  0         0  
4647             }
4648 0         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       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  
  0         0  
4655             else {
4656 0         0 while ($string !~ /\G \z/oxgc) {
4657 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4658 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4659 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4660 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4661 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4662 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4663 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0         0  
4664 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0         0  
4665             }
4666 0         0 die __FILE__, ": Search pattern not terminated\n";
4667             }
4668             }
4669              
4670             # split ''
4671             elsif ($string =~ /\G (\') /oxgc) {
4672 0         0 my $q_string = '';
4673 0         0 while ($string !~ /\G \z/oxgc) {
4674 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4675 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4676 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4677 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4678             }
4679 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4680             }
4681              
4682             # split ""
4683             elsif ($string =~ /\G (\") /oxgc) {
4684 0         0 my $qq_string = '';
4685 0         0 while ($string !~ /\G \z/oxgc) {
4686 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4687 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4688 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4689 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4690             }
4691 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4692             }
4693              
4694             # split //
4695             elsif ($string =~ /\G (\/) /oxgc) {
4696 0         0 my $regexp = '';
4697 0         0 while ($string !~ /\G \z/oxgc) {
4698 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4699 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4700 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4701 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4702             }
4703 0         0 die __FILE__, ": Search pattern not terminated\n";
4704             }
4705             }
4706              
4707             # qq//
4708             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4709 0         0 my $ope = $1;
4710 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4711 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4712             }
4713             else {
4714 0         0 my $e = '';
4715 0         0 while ($string !~ /\G \z/oxgc) {
4716 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4717 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4718 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4719 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4720 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4721 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0         0  
4722             }
4723 0         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         0 my $ope = $1;
4730 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4731 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4732             }
4733             else {
4734 0         0 my $e = '';
4735 0         0 while ($string !~ /\G \z/oxgc) {
4736 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4737 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4738 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4739 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4740 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4741 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4742 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0         0  
4743             }
4744 0         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         0 my $ope = $1;
4751 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4752 0         0 $e_string .= e_q($ope,$1,$3,$2);
4753             }
4754             else {
4755 0         0 my $e = '';
4756 0         0 while ($string !~ /\G \z/oxgc) {
4757 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4758 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4759 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4760 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4761 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4762 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0         0  
4763             }
4764 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4765             }
4766             }
4767              
4768             # ''
4769 0         0 elsif ($string =~ /\G (?
4770              
4771             # ""
4772 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4773              
4774             # ``
4775 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4776              
4777             # <<>> (a safer ARGV)
4778 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4779              
4780             # <<= <=> <= < operator
4781 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4782              
4783             #
4784 0         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         0 $e_string .= 'Elatin8::glob("' . $1 . '")';
4789             }
4790              
4791             # << (bit shift) --- not here document
4792 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4793              
4794             # <<'HEREDOC'
4795             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4796 0         0 $slash = 'm//';
4797 0         0 my $here_quote = $1;
4798 0         0 my $delimiter = $2;
4799              
4800             # get here document
4801 0 0       0 if ($here_script eq '') {
4802 0         0 $here_script = CORE::substr $_, pos $_;
4803 0         0 $here_script =~ s/.*?\n//oxm;
4804             }
4805 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4806 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4807 0         0 push @heredoc_delimiter, $delimiter;
4808             }
4809             else {
4810 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4811             }
4812 0         0 $e_string .= $here_quote;
4813             }
4814              
4815             # <<\HEREDOC
4816             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4817 0         0 $slash = 'm//';
4818 0         0 my $here_quote = $1;
4819 0         0 my $delimiter = $2;
4820              
4821             # get here document
4822 0 0       0 if ($here_script eq '') {
4823 0         0 $here_script = CORE::substr $_, pos $_;
4824 0         0 $here_script =~ s/.*?\n//oxm;
4825             }
4826 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4827 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4828 0         0 push @heredoc_delimiter, $delimiter;
4829             }
4830             else {
4831 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4832             }
4833 0         0 $e_string .= $here_quote;
4834             }
4835              
4836             # <<"HEREDOC"
4837             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4838 0         0 $slash = 'm//';
4839 0         0 my $here_quote = $1;
4840 0         0 my $delimiter = $2;
4841              
4842             # get here document
4843 0 0       0 if ($here_script eq '') {
4844 0         0 $here_script = CORE::substr $_, pos $_;
4845 0         0 $here_script =~ s/.*?\n//oxm;
4846             }
4847 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4848 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4849 0         0 push @heredoc_delimiter, $delimiter;
4850             }
4851             else {
4852 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4853             }
4854 0         0 $e_string .= $here_quote;
4855             }
4856              
4857             # <
4858             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4859 0         0 $slash = 'm//';
4860 0         0 my $here_quote = $1;
4861 0         0 my $delimiter = $2;
4862              
4863             # get here document
4864 0 0       0 if ($here_script eq '') {
4865 0         0 $here_script = CORE::substr $_, pos $_;
4866 0         0 $here_script =~ s/.*?\n//oxm;
4867             }
4868 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4869 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4870 0         0 push @heredoc_delimiter, $delimiter;
4871             }
4872             else {
4873 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4874             }
4875 0         0 $e_string .= $here_quote;
4876             }
4877              
4878             # <<`HEREDOC`
4879             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4880 0         0 $slash = 'm//';
4881 0         0 my $here_quote = $1;
4882 0         0 my $delimiter = $2;
4883              
4884             # get here document
4885 0 0       0 if ($here_script eq '') {
4886 0         0 $here_script = CORE::substr $_, pos $_;
4887 0         0 $here_script =~ s/.*?\n//oxm;
4888             }
4889 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4890 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4891 0         0 push @heredoc_delimiter, $delimiter;
4892             }
4893             else {
4894 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4895             }
4896 0         0 $e_string .= $here_quote;
4897             }
4898              
4899             # any operator before div
4900             elsif ($string =~ /\G (
4901             -- | \+\+ |
4902             [\)\}\]]
4903              
4904 18         26 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         51  
4905              
4906             # yada-yada or triple-dot operator
4907             elsif ($string =~ /\G (
4908             \.\.\.
4909              
4910 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         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 31         38 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         110  
4942              
4943             # other any character
4944 131         336 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4945              
4946             # system error
4947             else {
4948 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4949             }
4950             }
4951              
4952 17         64 return $e_string;
4953             }
4954              
4955             #
4956             # character class
4957             #
4958             sub character_class {
4959 1914     1914 0 2557 my($char,$modifier) = @_;
4960              
4961 1914 100       2658 if ($char eq '.') {
4962 52 100       85 if ($modifier =~ /s/) {
4963 17         34 return '${Elatin8::dot_s}';
4964             }
4965             else {
4966 35         69 return '${Elatin8::dot}';
4967             }
4968             }
4969             else {
4970 1862         2945 return Elatin8::classic_character_class($char);
4971             }
4972             }
4973              
4974             #
4975             # escape capture ($1, $2, $3, ...)
4976             #
4977             sub e_capture {
4978              
4979 212     212 0 866 return join '', '${', $_[0], '}';
4980             }
4981              
4982             #
4983             # escape transliteration (tr/// or y///)
4984             #
4985             sub e_tr {
4986 3     3 0 14 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4987 3         6 my $e_tr = '';
4988 3   50     10 $modifier ||= '';
4989              
4990 3         7 $slash = 'div';
4991              
4992             # quote character class 1
4993 3         11 $charclass = q_tr($charclass);
4994              
4995             # quote character class 2
4996 3         9 $charclass2 = q_tr($charclass2);
4997              
4998             # /b /B modifier
4999 3 50       15 if ($modifier =~ tr/bB//d) {
5000 0 0       0 if ($variable eq '') {
5001 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
5002             }
5003             else {
5004 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5005             }
5006             }
5007             else {
5008 3 100       11 if ($variable eq '') {
5009 2         12 $e_tr = qq{Elatin8::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5010             }
5011             else {
5012 1         8 $e_tr = qq{Elatin8::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5013             }
5014             }
5015              
5016             # clear tr/// variable
5017 3         6 $tr_variable = '';
5018 3         3 $bind_operator = '';
5019              
5020 3         28 return $e_tr;
5021             }
5022              
5023             #
5024             # quote for escape transliteration (tr/// or y///)
5025             #
5026             sub q_tr {
5027 6     6 0 10 my($charclass) = @_;
5028              
5029             # quote character class
5030 6 50       17 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5031 6         13 return e_q('', "'", "'", $charclass); # --> q' '
5032             }
5033             elsif ($charclass !~ /\//oxms) {
5034 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
5035             }
5036             elsif ($charclass !~ /\#/oxms) {
5037 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
5038             }
5039             elsif ($charclass !~ /[\<\>]/oxms) {
5040 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
5041             }
5042             elsif ($charclass !~ /[\(\)]/oxms) {
5043 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
5044             }
5045             elsif ($charclass !~ /[\{\}]/oxms) {
5046 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5047             }
5048             else {
5049 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5050 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5051 0         0 return e_q('q', $char, $char, $charclass);
5052             }
5053             }
5054             }
5055              
5056 0         0 return e_q('q', '{', '}', $charclass);
5057             }
5058              
5059             #
5060             # escape q string (q//, '')
5061             #
5062             sub e_q {
5063 1092     1092 0 2274 my($ope,$delimiter,$end_delimiter,$string) = @_;
5064              
5065 1092         1285 $slash = 'div';
5066              
5067 1092         5818 return join '', $ope, $delimiter, $string, $end_delimiter;
5068             }
5069              
5070             #
5071             # escape qq string (qq//, "", qx//, ``)
5072             #
5073             sub e_qq {
5074 4019     4019 0 7193 my($ope,$delimiter,$end_delimiter,$string) = @_;
5075              
5076 4019         4477 $slash = 'div';
5077              
5078 4019         4416 my $left_e = 0;
5079 4019         3451 my $right_e = 0;
5080              
5081             # split regexp
5082 4019         168874 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 4019         15255 for (my $i=0; $i <= $#char; $i++) {
5099              
5100             # "\L\u" --> "\u\L"
5101 112032 50 33     459574 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5102 0         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         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 1         3 $char[$i] = Elatin8::octchr($1);
5113             }
5114              
5115             # hexadecimal escape sequence
5116             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5117 1         3 $char[$i] = Elatin8::hexchr($1);
5118             }
5119              
5120             # \N{CHARNAME} --> N{CHARNAME}
5121             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5122 0         0 $char[$i] = $1;
5123             }
5124              
5125 112032 100       1250109 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
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         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5137 484 50       1188 if ($right_e < $left_e) {
5138 0         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         0 $char[$i] = '@{[Elatin8::ucfirst qq<';
5156 0         0 $left_e++;
5157             }
5158             elsif ($char[$i] eq '\l') {
5159 0         0 $char[$i] = '@{[Elatin8::lcfirst qq<';
5160 0         0 $left_e++;
5161             }
5162             elsif ($char[$i] eq '\U') {
5163 0         0 $char[$i] = '@{[Elatin8::uc qq<';
5164 0         0 $left_e++;
5165             }
5166             elsif ($char[$i] eq '\L') {
5167 0         0 $char[$i] = '@{[Elatin8::lc qq<';
5168 0         0 $left_e++;
5169             }
5170             elsif ($char[$i] eq '\F') {
5171 24         24 $char[$i] = '@{[Elatin8::fc qq<';
5172 24         41 $left_e++;
5173             }
5174             elsif ($char[$i] eq '\Q') {
5175 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5176 0         0 $left_e++;
5177             }
5178             elsif ($char[$i] eq '\E') {
5179 24 50       30 if ($right_e < $left_e) {
5180 24         24 $char[$i] = '>]}';
5181 24         38 $right_e++;
5182             }
5183             else {
5184 0         0 $char[$i] = '';
5185             }
5186             }
5187             elsif ($char[$i] eq '\Q') {
5188 0         0 while (1) {
5189 0 0       0 if (++$i > $#char) {
5190 0         0 last;
5191             }
5192 0 0       0 if ($char[$i] eq '\E') {
5193 0         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 205         416 $char[$i] = e_capture($1);
5214             }
5215             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5216 0         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         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         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         0 $char[$i] = e_capture($1);
5232             }
5233              
5234             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
5235             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5236 44         126 $char[$i] = '@{[Elatin8::PREMATCH()]}';
5237             }
5238              
5239             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5240             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5241 45         129 $char[$i] = '@{[Elatin8::MATCH()]}';
5242             }
5243              
5244             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5245             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5246 33         92 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
5256             }
5257             }
5258              
5259             # return string
5260 4019 50       8722 if ($left_e > $right_e) {
5261 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5262             }
5263 4019         39491 return join '', $ope, $delimiter, @char, $end_delimiter;
5264             }
5265              
5266             #
5267             # escape qw string (qw//)
5268             #
5269             sub e_qw {
5270 16     16 0 98 my($ope,$delimiter,$end_delimiter,$string) = @_;
5271              
5272 16         25 $slash = 'div';
5273              
5274             # choice again delimiter
5275 16         235 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         622  
5276 16 50       103 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5277 16         122 return join '', $ope, $delimiter, $string, $end_delimiter;
5278             }
5279             elsif (not $octet{')'}) {
5280 0         0 return join '', $ope, '(', $string, ')';
5281             }
5282             elsif (not $octet{'}'}) {
5283 0         0 return join '', $ope, '{', $string, '}';
5284             }
5285             elsif (not $octet{']'}) {
5286 0         0 return join '', $ope, '[', $string, ']';
5287             }
5288             elsif (not $octet{'>'}) {
5289 0         0 return join '', $ope, '<', $string, '>';
5290             }
5291             else {
5292 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5293 0 0       0 if (not $octet{$char}) {
5294 0         0 return join '', $ope, $char, $string, $char;
5295             }
5296             }
5297             }
5298              
5299             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5300 0         0 my @string = CORE::split(/\s+/, $string);
5301 0         0 for my $string (@string) {
5302 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5303 0         0 for my $octet (@octet) {
5304 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5305 0         0 $octet = '\\' . $1;
5306             }
5307             }
5308 0         0 $string = join '', @octet;
5309             }
5310 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5311             }
5312              
5313             #
5314             # escape here document (<<"HEREDOC", <
5315             #
5316             sub e_heredoc {
5317 78     78 0 187 my($string) = @_;
5318              
5319 78         103 $slash = 'm//';
5320              
5321 78         288 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5322              
5323 78         108 my $left_e = 0;
5324 78         78 my $right_e = 0;
5325              
5326             # split regexp
5327 78         8334 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 78         468 for (my $i=0; $i <= $#char; $i++) {
5344              
5345             # "\L\u" --> "\u\L"
5346 2882 50 33     11658 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5347 0         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         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 1         4 $char[$i] = Elatin8::octchr($1);
5358             }
5359              
5360             # hexadecimal escape sequence
5361             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5362 1         2 $char[$i] = Elatin8::hexchr($1);
5363             }
5364              
5365             # \N{CHARNAME} --> N{CHARNAME}
5366             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5367 0         0 $char[$i] = $1;
5368             }
5369              
5370 2882 50       33859 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5371             }
5372              
5373             # \u \l \U \L \F \Q \E
5374 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5375 0 0       0 if ($right_e < $left_e) {
5376 0         0 $char[$i] = '\\' . $char[$i];
5377             }
5378             }
5379             elsif ($char[$i] eq '\u') {
5380 0         0 $char[$i] = '@{[Elatin8::ucfirst qq<';
5381 0         0 $left_e++;
5382             }
5383             elsif ($char[$i] eq '\l') {
5384 0         0 $char[$i] = '@{[Elatin8::lcfirst qq<';
5385 0         0 $left_e++;
5386             }
5387             elsif ($char[$i] eq '\U') {
5388 0         0 $char[$i] = '@{[Elatin8::uc qq<';
5389 0         0 $left_e++;
5390             }
5391             elsif ($char[$i] eq '\L') {
5392 0         0 $char[$i] = '@{[Elatin8::lc qq<';
5393 0         0 $left_e++;
5394             }
5395             elsif ($char[$i] eq '\F') {
5396 0         0 $char[$i] = '@{[Elatin8::fc qq<';
5397 0         0 $left_e++;
5398             }
5399             elsif ($char[$i] eq '\Q') {
5400 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5401 0         0 $left_e++;
5402             }
5403             elsif ($char[$i] eq '\E') {
5404 0 0       0 if ($right_e < $left_e) {
5405 0         0 $char[$i] = '>]}';
5406 0         0 $right_e++;
5407             }
5408             else {
5409 0         0 $char[$i] = '';
5410             }
5411             }
5412             elsif ($char[$i] eq '\Q') {
5413 0         0 while (1) {
5414 0 0       0 if (++$i > $#char) {
5415 0         0 last;
5416             }
5417 0 0       0 if ($char[$i] eq '\E') {
5418 0         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         0 $char[$i] = e_capture($1);
5439             }
5440             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5441 0         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         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         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         0 $char[$i] = e_capture($1);
5457             }
5458              
5459             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
5460             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5461 8         41 $char[$i] = '@{[Elatin8::PREMATCH()]}';
5462             }
5463              
5464             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5465             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5466 8         41 $char[$i] = '@{[Elatin8::MATCH()]}';
5467             }
5468              
5469             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5470             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5471 6         41 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
5481             }
5482             }
5483              
5484             # return string
5485 78 50       182 if ($left_e > $right_e) {
5486 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5487             }
5488 78         801 return join '', @char;
5489             }
5490              
5491             #
5492             # escape regexp (m//, qr//)
5493             #
5494             sub e_qr {
5495 651     651 0 2081 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5496 651   100     2449 $modifier ||= '';
5497              
5498 651         1050 $modifier =~ tr/p//d;
5499 651 50       1743 if ($modifier =~ /([adlu])/oxms) {
5500 0         0 my $line = 0;
5501 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5502 0 0       0 if ($filename ne __FILE__) {
5503 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5504 0         0 last;
5505             }
5506             }
5507 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5508             }
5509              
5510 651         923 $slash = 'div';
5511              
5512             # literal null string pattern
5513 651 100       2305 if ($string eq '') {
    100          
5514 8         7 $modifier =~ tr/bB//d;
5515 8         10 $modifier =~ tr/i//d;
5516 8         37 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 2 50       17 if ($delimiter =~ / [\@:] /oxms) {
5524 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5525 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5526 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5527 0         0 $delimiter = '(';
5528 0         0 $end_delimiter = ')';
5529             }
5530             elsif (not $octet{'}'}) {
5531 0         0 $delimiter = '{';
5532 0         0 $end_delimiter = '}';
5533             }
5534             elsif (not $octet{']'}) {
5535 0         0 $delimiter = '[';
5536 0         0 $end_delimiter = ']';
5537             }
5538             elsif (not $octet{'>'}) {
5539 0         0 $delimiter = '<';
5540 0         0 $end_delimiter = '>';
5541             }
5542             else {
5543 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5544 0 0       0 if (not $octet{$char}) {
5545 0         0 $delimiter = $char;
5546 0         0 $end_delimiter = $char;
5547 0         0 last;
5548             }
5549             }
5550             }
5551             }
5552              
5553 2 50 33     13 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5554 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5555             }
5556             else {
5557 2         10 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5558             }
5559             }
5560              
5561 641 100       1585 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5562 641         2704 my $metachar = qr/[\@\\|[\]{^]/oxms;
5563              
5564             # split regexp
5565 641         71887 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 641 50       3379 if ($delimiter =~ / [\@:] /oxms) {
5591 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5592 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5593 0         0 $delimiter = '(';
5594 0         0 $end_delimiter = ')';
5595             }
5596             elsif (not $octet{'}'}) {
5597 0         0 $delimiter = '{';
5598 0         0 $end_delimiter = '}';
5599             }
5600             elsif (not $octet{']'}) {
5601 0         0 $delimiter = '[';
5602 0         0 $end_delimiter = ']';
5603             }
5604             elsif (not $octet{'>'}) {
5605 0         0 $delimiter = '<';
5606 0         0 $end_delimiter = '>';
5607             }
5608             else {
5609 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5610 0 0       0 if (not $octet{$char}) {
5611 0         0 $delimiter = $char;
5612 0         0 $end_delimiter = $char;
5613 0         0 last;
5614             }
5615             }
5616             }
5617             }
5618              
5619 641         888 my $left_e = 0;
5620 641         796 my $right_e = 0;
5621 641         1938 for (my $i=0; $i <= $#char; $i++) {
5622              
5623             # "\L\u" --> "\u\L"
5624 1867 50 66     12561 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5625 0         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         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 1         2 $char[$i] = Elatin8::octchr($1);
5636             }
5637              
5638             # hexadecimal escape sequence
5639             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5640 1         3 $char[$i] = Elatin8::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 6         18 $char[$i] = $1 . '\\' . $2;
5650             }
5651              
5652             # \p, \P, \X --> p, P, X
5653             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5654 4         14 $char[$i] = $1;
5655             }
5656              
5657 1867 100 100     6598 if (0) {
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5658             }
5659              
5660             # join separated multiple-octet
5661 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5662 6 50 33     131 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)) {
    50 33        
    50 33        
      33        
      66        
      33        
5663 0         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         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         0 $char[$i] .= join '', splice @char, $i+1, 1;
5670             }
5671             }
5672              
5673             # open character class [...]
5674             elsif ($char[$i] eq '[') {
5675 328         448 my $left = $i;
5676              
5677             # [] make die "Unmatched [] in regexp ...\n"
5678             # (and so on)
5679              
5680 328 100       952 if ($char[$i+1] eq ']') {
5681 3         6 $i++;
5682             }
5683              
5684 328         390 while (1) {
5685 1379 50       2216 if (++$i > $#char) {
5686 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5687             }
5688 1379 100       2327 if ($char[$i] eq ']') {
5689 328         424 my $right = $i;
5690              
5691             # [...]
5692 328 100       2204 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5693 30         93 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         184  
5694             }
5695             else {
5696 298         1421 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
5697             }
5698              
5699 328         518 $i = $left;
5700 328         1125 last;
5701             }
5702             }
5703             }
5704              
5705             # open character class [^...]
5706             elsif ($char[$i] eq '[^') {
5707 74         112 my $left = $i;
5708              
5709             # [^] make die "Unmatched [] in regexp ...\n"
5710             # (and so on)
5711              
5712 74 100       207 if ($char[$i+1] eq ']') {
5713 4         6 $i++;
5714             }
5715              
5716 74         78 while (1) {
5717 272 50       443 if (++$i > $#char) {
5718 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5719             }
5720 272 100       561 if ($char[$i] eq ']') {
5721 74         80 my $right = $i;
5722              
5723             # [^...]
5724 74 100       546 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5725 30         71 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         136  
5726             }
5727             else {
5728 44         311 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5729             }
5730              
5731 74         136 $i = $left;
5732 74         270 last;
5733             }
5734             }
5735             }
5736              
5737             # rewrite character class or escape character
5738             elsif (my $char = character_class($char[$i],$modifier)) {
5739 139         617 $char[$i] = $char;
5740             }
5741              
5742             # /i modifier
5743             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
5744 20 50       31 if (CORE::length(Elatin8::fc($char[$i])) == 1) {
5745 20         31 $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
5746             }
5747             else {
5748 0         0 $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
5749             }
5750             }
5751              
5752             # \u \l \U \L \F \Q \E
5753             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5754 1 50       6 if ($right_e < $left_e) {
5755 0         0 $char[$i] = '\\' . $char[$i];
5756             }
5757             }
5758             elsif ($char[$i] eq '\u') {
5759 0         0 $char[$i] = '@{[Elatin8::ucfirst qq<';
5760 0         0 $left_e++;
5761             }
5762             elsif ($char[$i] eq '\l') {
5763 0         0 $char[$i] = '@{[Elatin8::lcfirst qq<';
5764 0         0 $left_e++;
5765             }
5766             elsif ($char[$i] eq '\U') {
5767 1         2 $char[$i] = '@{[Elatin8::uc qq<';
5768 1         5 $left_e++;
5769             }
5770             elsif ($char[$i] eq '\L') {
5771 1         1 $char[$i] = '@{[Elatin8::lc qq<';
5772 1         5 $left_e++;
5773             }
5774             elsif ($char[$i] eq '\F') {
5775 18         22 $char[$i] = '@{[Elatin8::fc qq<';
5776 18         64 $left_e++;
5777             }
5778             elsif ($char[$i] eq '\Q') {
5779 1         3 $char[$i] = '@{[CORE::quotemeta qq<';
5780 1         5 $left_e++;
5781             }
5782             elsif ($char[$i] eq '\E') {
5783 21 50       29 if ($right_e < $left_e) {
5784 21         20 $char[$i] = '>]}';
5785 21         65 $right_e++;
5786             }
5787             else {
5788 0         0 $char[$i] = '';
5789             }
5790             }
5791             elsif ($char[$i] eq '\Q') {
5792 0         0 while (1) {
5793 0 0       0 if (++$i > $#char) {
5794 0         0 last;
5795             }
5796 0 0       0 if ($char[$i] eq '\E') {
5797 0         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       0 if ($ignorecase) {
5807 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5808             }
5809             }
5810             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5811 0 0       0 if ($ignorecase) {
5812 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
5824 0 0       0 if ($ignorecase) {
5825 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5826             }
5827             }
5828             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5829 0         0 $char[$i] = e_capture($1);
5830 0 0       0 if ($ignorecase) {
5831 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1.'->'.$2);
5838 0 0       0 if ($ignorecase) {
5839 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1.'->'.$2);
5846 0 0       0 if ($ignorecase) {
5847 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
5854 0 0       0 if ($ignorecase) {
5855 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5856             }
5857             }
5858              
5859             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
5860             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5861 8 50       24 if ($ignorecase) {
5862 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
5863             }
5864             else {
5865 8         116 $char[$i] = '@{[Elatin8::PREMATCH()]}';
5866             }
5867             }
5868              
5869             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5870             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5871 8 50       17 if ($ignorecase) {
5872 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
5873             }
5874             else {
5875 8         36 $char[$i] = '@{[Elatin8::MATCH()]}';
5876             }
5877             }
5878              
5879             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5880             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5881 6 50       19 if ($ignorecase) {
5882 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
5883             }
5884             else {
5885 6         36 $char[$i] = '@{[Elatin8::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       0 if ($ignorecase) {
5892 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5893             }
5894             }
5895              
5896             # ${ ... }
5897             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5898 0         0 $char[$i] = e_capture($1);
5899 0 0       0 if ($ignorecase) {
5900 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5901             }
5902             }
5903              
5904             # $scalar or @array
5905             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5906 21         39 $char[$i] = e_string($char[$i]);
5907 21 100       71 if ($ignorecase) {
5908 11         53 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5909             }
5910             }
5911              
5912             # quote character before ? + * {
5913             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5914 138 100 33     1362 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5915             }
5916             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5917 0         0 my $char = $char[$i-1];
5918 0 0       0 if ($char[$i] eq '{') {
5919 0         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         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 127         900 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5927             }
5928             }
5929             }
5930              
5931             # make regexp string
5932 641         952 $modifier =~ tr/i//d;
5933 641 50       1517 if ($left_e > $right_e) {
5934 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5935 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5936             }
5937             else {
5938 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5939             }
5940             }
5941 641 50 33     4462 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5942 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5943             }
5944             else {
5945 641         7438 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5946             }
5947             }
5948              
5949             #
5950             # double quote stuff
5951             #
5952             sub qq_stuff {
5953 180     180 0 226 my($delimiter,$end_delimiter,$stuff) = @_;
5954              
5955             # scalar variable or array variable
5956 180 100       474 if ($stuff =~ /\A [\$\@] /oxms) {
5957 100         395 return $stuff;
5958             }
5959              
5960             # quote by delimiter
5961 80         212 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         300  
5962 80         326 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5963 80 50       159 next if $char eq $delimiter;
5964 80 50       139 next if $char eq $end_delimiter;
5965 80 50       170 if (not $octet{$char}) {
5966 80         516 return join '', 'qq', $char, $stuff, $char;
5967             }
5968             }
5969 0         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 10     10 0 22 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5977 10   50     30 $modifier ||= '';
5978              
5979 10         11 $modifier =~ tr/p//d;
5980 10 50       22 if ($modifier =~ /([adlu])/oxms) {
5981 0         0 my $line = 0;
5982 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5983 0 0       0 if ($filename ne __FILE__) {
5984 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5985 0         0 last;
5986             }
5987             }
5988 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5989             }
5990              
5991 10         8 $slash = 'div';
5992              
5993             # literal null string pattern
5994 10 100       22 if ($string eq '') {
    50          
5995 8         4 $modifier =~ tr/bB//d;
5996 8         14 $modifier =~ tr/i//d;
5997 8         38 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5998             }
5999              
6000             # with /b /B modifier
6001             elsif ($modifier =~ tr/bB//d) {
6002 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6003             }
6004              
6005             # without /b /B modifier
6006             else {
6007 2         6 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 2     2 0 4 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6016              
6017 2 50       6 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6018              
6019             # split regexp
6020 2         65 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 2         9 for (my $i=0; $i <= $#char; $i++) {
6033 2 50 33     13 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
6034             }
6035              
6036             # open character class [...]
6037 0         0 elsif ($char[$i] eq '[') {
6038 0         0 my $left = $i;
6039 0 0       0 if ($char[$i+1] eq ']') {
6040 0         0 $i++;
6041             }
6042 0         0 while (1) {
6043 0 0       0 if (++$i > $#char) {
6044 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6045             }
6046 0 0       0 if ($char[$i] eq ']') {
6047 0         0 my $right = $i;
6048              
6049             # [...]
6050 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6051              
6052 0         0 $i = $left;
6053 0         0 last;
6054             }
6055             }
6056             }
6057              
6058             # open character class [^...]
6059             elsif ($char[$i] eq '[^') {
6060 0         0 my $left = $i;
6061 0 0       0 if ($char[$i+1] eq ']') {
6062 0         0 $i++;
6063             }
6064 0         0 while (1) {
6065 0 0       0 if (++$i > $#char) {
6066 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6067             }
6068 0 0       0 if ($char[$i] eq ']') {
6069 0         0 my $right = $i;
6070              
6071             # [^...]
6072 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6073              
6074 0         0 $i = $left;
6075 0         0 last;
6076             }
6077             }
6078             }
6079              
6080             # escape $ @ / and \
6081             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6082 0         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         0 $char[$i] = $char;
6088             }
6089              
6090             # /i modifier
6091             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6092 0 0       0 if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6093 0         0 $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6094             }
6095             else {
6096 0         0 $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6097             }
6098             }
6099              
6100             # quote character before ? + * {
6101             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6102 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6103             }
6104             else {
6105 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6106             }
6107             }
6108             }
6109              
6110 2         5 $delimiter = '/';
6111 2         2 $end_delimiter = '/';
6112              
6113 2         3 $modifier =~ tr/i//d;
6114 2         12 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 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6122              
6123             # split regexp
6124 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6125              
6126             # unescape character
6127 0         0 for (my $i=0; $i <= $#char; $i++) {
6128 0 0       0 if (0) {
    0          
6129             }
6130              
6131             # remain \\
6132 0         0 elsif ($char[$i] eq '\\\\') {
6133             }
6134              
6135             # escape $ @ / and \
6136             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6137 0         0 $char[$i] = '\\' . $char[$i];
6138             }
6139             }
6140              
6141 0         0 $delimiter = '/';
6142 0         0 $end_delimiter = '/';
6143 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6144             }
6145              
6146             #
6147             # escape regexp (s/here//)
6148             #
6149             sub e_s1 {
6150 76     76 0 183 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6151 76   100     279 $modifier ||= '';
6152              
6153 76         109 $modifier =~ tr/p//d;
6154 76 50       222 if ($modifier =~ /([adlu])/oxms) {
6155 0         0 my $line = 0;
6156 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6157 0 0       0 if ($filename ne __FILE__) {
6158 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6159 0         0 last;
6160             }
6161             }
6162 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6163             }
6164              
6165 76         119 $slash = 'div';
6166              
6167             # literal null string pattern
6168 76 100       283 if ($string eq '') {
    50          
6169 8         8 $modifier =~ tr/bB//d;
6170 8         6 $modifier =~ tr/i//d;
6171 8         46 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       0 if ($delimiter =~ / [\@:] /oxms) {
6179 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6180 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6181 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6182 0         0 $delimiter = '(';
6183 0         0 $end_delimiter = ')';
6184             }
6185             elsif (not $octet{'}'}) {
6186 0         0 $delimiter = '{';
6187 0         0 $end_delimiter = '}';
6188             }
6189             elsif (not $octet{']'}) {
6190 0         0 $delimiter = '[';
6191 0         0 $end_delimiter = ']';
6192             }
6193             elsif (not $octet{'>'}) {
6194 0         0 $delimiter = '<';
6195 0         0 $end_delimiter = '>';
6196             }
6197             else {
6198 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6199 0 0       0 if (not $octet{$char}) {
6200 0         0 $delimiter = $char;
6201 0         0 $end_delimiter = $char;
6202 0         0 last;
6203             }
6204             }
6205             }
6206             }
6207              
6208 0         0 my $prematch = '';
6209 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6210             }
6211              
6212 68 100       188 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6213 68         315 my $metachar = qr/[\@\\|[\]{^]/oxms;
6214              
6215             # split regexp
6216 68         18225 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 68 50       583 if ($delimiter =~ / [\@:] /oxms) {
6246 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6247 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6248 0         0 $delimiter = '(';
6249 0         0 $end_delimiter = ')';
6250             }
6251             elsif (not $octet{'}'}) {
6252 0         0 $delimiter = '{';
6253 0         0 $end_delimiter = '}';
6254             }
6255             elsif (not $octet{']'}) {
6256 0         0 $delimiter = '[';
6257 0         0 $end_delimiter = ']';
6258             }
6259             elsif (not $octet{'>'}) {
6260 0         0 $delimiter = '<';
6261 0         0 $end_delimiter = '>';
6262             }
6263             else {
6264 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6265 0 0       0 if (not $octet{$char}) {
6266 0         0 $delimiter = $char;
6267 0         0 $end_delimiter = $char;
6268 0         0 last;
6269             }
6270             }
6271             }
6272             }
6273              
6274             # count '('
6275 68         126 my $parens = grep { $_ eq '(' } @char;
  253         412  
6276              
6277 68         90 my $left_e = 0;
6278 68         81 my $right_e = 0;
6279 68         243 for (my $i=0; $i <= $#char; $i++) {
6280              
6281             # "\L\u" --> "\u\L"
6282 195 50 33     1382 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6283 0         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         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 1         2 $char[$i] = Elatin8::octchr($1);
6294             }
6295              
6296             # hexadecimal escape sequence
6297             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6298 1         2 $char[$i] = Elatin8::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         0 $char[$i] = $1 . '\\' . $2;
6308             }
6309              
6310             # \p, \P, \X --> p, P, X
6311             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6312 0         0 $char[$i] = $1;
6313             }
6314              
6315 195 50 66     779 if (0) {
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6316             }
6317              
6318             # join separated multiple-octet
6319 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6320 0 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         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         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         0 $char[$i] .= join '', splice @char, $i+1, 1;
6328             }
6329             }
6330              
6331             # open character class [...]
6332             elsif ($char[$i] eq '[') {
6333 13         23 my $left = $i;
6334 13 50       54 if ($char[$i+1] eq ']') {
6335 0         0 $i++;
6336             }
6337 13         16 while (1) {
6338 58 50       95 if (++$i > $#char) {
6339 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6340             }
6341 58 100       111 if ($char[$i] eq ']') {
6342 13         15 my $right = $i;
6343              
6344             # [...]
6345 13 50       99 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6346 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6347             }
6348             else {
6349 13         125 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6350             }
6351              
6352 13         27 $i = $left;
6353 13         40 last;
6354             }
6355             }
6356             }
6357              
6358             # open character class [^...]
6359             elsif ($char[$i] eq '[^') {
6360 0         0 my $left = $i;
6361 0 0       0 if ($char[$i+1] eq ']') {
6362 0         0 $i++;
6363             }
6364 0         0 while (1) {
6365 0 0       0 if (++$i > $#char) {
6366 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6367             }
6368 0 0       0 if ($char[$i] eq ']') {
6369 0         0 my $right = $i;
6370              
6371             # [^...]
6372 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6373 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6374             }
6375             else {
6376 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6377             }
6378              
6379 0         0 $i = $left;
6380 0         0 last;
6381             }
6382             }
6383             }
6384              
6385             # rewrite character class or escape character
6386             elsif (my $char = character_class($char[$i],$modifier)) {
6387 7         14 $char[$i] = $char;
6388             }
6389              
6390             # /i modifier
6391             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6392 3 50       5 if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6393 3         5 $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6394             }
6395             else {
6396 0         0 $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6397             }
6398             }
6399              
6400             # \u \l \U \L \F \Q \E
6401             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6402 0 0       0 if ($right_e < $left_e) {
6403 0         0 $char[$i] = '\\' . $char[$i];
6404             }
6405             }
6406             elsif ($char[$i] eq '\u') {
6407 0         0 $char[$i] = '@{[Elatin8::ucfirst qq<';
6408 0         0 $left_e++;
6409             }
6410             elsif ($char[$i] eq '\l') {
6411 0         0 $char[$i] = '@{[Elatin8::lcfirst qq<';
6412 0         0 $left_e++;
6413             }
6414             elsif ($char[$i] eq '\U') {
6415 0         0 $char[$i] = '@{[Elatin8::uc qq<';
6416 0         0 $left_e++;
6417             }
6418             elsif ($char[$i] eq '\L') {
6419 0         0 $char[$i] = '@{[Elatin8::lc qq<';
6420 0         0 $left_e++;
6421             }
6422             elsif ($char[$i] eq '\F') {
6423 0         0 $char[$i] = '@{[Elatin8::fc qq<';
6424 0         0 $left_e++;
6425             }
6426             elsif ($char[$i] eq '\Q') {
6427 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6428 0         0 $left_e++;
6429             }
6430             elsif ($char[$i] eq '\E') {
6431 0 0       0 if ($right_e < $left_e) {
6432 0         0 $char[$i] = '>]}';
6433 0         0 $right_e++;
6434             }
6435             else {
6436 0         0 $char[$i] = '';
6437             }
6438             }
6439             elsif ($char[$i] eq '\Q') {
6440 0         0 while (1) {
6441 0 0       0 if (++$i > $#char) {
6442 0         0 last;
6443             }
6444 0 0       0 if ($char[$i] eq '\E') {
6445 0         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       0 if ($ignorecase) {
6485 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6486             }
6487             }
6488             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6489 0 0       0 if ($ignorecase) {
6490 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
6502 0 0       0 if ($ignorecase) {
6503 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6504             }
6505             }
6506             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6507 0         0 $char[$i] = e_capture($1);
6508 0 0       0 if ($ignorecase) {
6509 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1.'->'.$2);
6516 0 0       0 if ($ignorecase) {
6517 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1.'->'.$2);
6524 0 0       0 if ($ignorecase) {
6525 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
6532 0 0       0 if ($ignorecase) {
6533 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6534             }
6535             }
6536              
6537             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
6538             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6539 4 50       12 if ($ignorecase) {
6540 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
6541             }
6542             else {
6543 4         35 $char[$i] = '@{[Elatin8::PREMATCH()]}';
6544             }
6545             }
6546              
6547             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
6548             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6549 4 50       12 if ($ignorecase) {
6550 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
6551             }
6552             else {
6553 4         18 $char[$i] = '@{[Elatin8::MATCH()]}';
6554             }
6555             }
6556              
6557             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
6558             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6559 3 50       15 if ($ignorecase) {
6560 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
6561             }
6562             else {
6563 3         18 $char[$i] = '@{[Elatin8::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       0 if ($ignorecase) {
6570 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6571             }
6572             }
6573              
6574             # ${ ... }
6575             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6576 0         0 $char[$i] = e_capture($1);
6577 0 0       0 if ($ignorecase) {
6578 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6579             }
6580             }
6581              
6582             # $scalar or @array
6583             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6584 4         16 $char[$i] = e_string($char[$i]);
6585 4 50       40 if ($ignorecase) {
6586 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6587             }
6588             }
6589              
6590             # quote character before ? + * {
6591             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6592 13 50       67 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 13         104 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6596             }
6597             }
6598             }
6599              
6600             # make regexp string
6601 68         134 my $prematch = '';
6602 68         107 $modifier =~ tr/i//d;
6603 68 50       225 if ($left_e > $right_e) {
6604 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6605             }
6606 68         843 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 21     21 0 33 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6614 21   100     61 $modifier ||= '';
6615              
6616 21         23 $modifier =~ tr/p//d;
6617 21 50       45 if ($modifier =~ /([adlu])/oxms) {
6618 0         0 my $line = 0;
6619 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6620 0 0       0 if ($filename ne __FILE__) {
6621 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6622 0         0 last;
6623             }
6624             }
6625 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6626             }
6627              
6628 21         26 $slash = 'div';
6629              
6630             # literal null string pattern
6631 21 100       49 if ($string eq '') {
    50          
6632 8         6 $modifier =~ tr/bB//d;
6633 8         6 $modifier =~ tr/i//d;
6634 8         43 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6635             }
6636              
6637             # with /b /B modifier
6638             elsif ($modifier =~ tr/bB//d) {
6639 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6640             }
6641              
6642             # without /b /B modifier
6643             else {
6644 13         26 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 13     13 0 22 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6653              
6654 13 50       29 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6655              
6656             # split regexp
6657 13         215 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 13         41 for (my $i=0; $i <= $#char; $i++) {
6670 25 50 33     117 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6671             }
6672              
6673             # open character class [...]
6674 0         0 elsif ($char[$i] eq '[') {
6675 0         0 my $left = $i;
6676 0 0       0 if ($char[$i+1] eq ']') {
6677 0         0 $i++;
6678             }
6679 0         0 while (1) {
6680 0 0       0 if (++$i > $#char) {
6681 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6682             }
6683 0 0       0 if ($char[$i] eq ']') {
6684 0         0 my $right = $i;
6685              
6686             # [...]
6687 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6688              
6689 0         0 $i = $left;
6690 0         0 last;
6691             }
6692             }
6693             }
6694              
6695             # open character class [^...]
6696             elsif ($char[$i] eq '[^') {
6697 0         0 my $left = $i;
6698 0 0       0 if ($char[$i+1] eq ']') {
6699 0         0 $i++;
6700             }
6701 0         0 while (1) {
6702 0 0       0 if (++$i > $#char) {
6703 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6704             }
6705 0 0       0 if ($char[$i] eq ']') {
6706 0         0 my $right = $i;
6707              
6708             # [^...]
6709 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6710              
6711 0         0 $i = $left;
6712 0         0 last;
6713             }
6714             }
6715             }
6716              
6717             # escape $ @ / and \
6718             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6719 0         0 $char[$i] = '\\' . $char[$i];
6720             }
6721              
6722             # rewrite character class or escape character
6723             elsif (my $char = character_class($char[$i],$modifier)) {
6724 6         10 $char[$i] = $char;
6725             }
6726              
6727             # /i modifier
6728             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6729 0 0       0 if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6730 0         0 $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6731             }
6732             else {
6733 0         0 $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6734             }
6735             }
6736              
6737             # quote character before ? + * {
6738             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6739 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6740             }
6741             else {
6742 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6743             }
6744             }
6745             }
6746              
6747 13         17 $modifier =~ tr/i//d;
6748 13         17 $delimiter = '/';
6749 13         18 $end_delimiter = '/';
6750 13         12 my $prematch = '';
6751 13         103 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 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6759              
6760             # split regexp
6761 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6762              
6763             # unescape character
6764 0         0 for (my $i=0; $i <= $#char; $i++) {
6765 0 0       0 if (0) {
    0          
6766             }
6767              
6768             # remain \\
6769 0         0 elsif ($char[$i] eq '\\\\') {
6770             }
6771              
6772             # escape $ @ / and \
6773             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6774 0         0 $char[$i] = '\\' . $char[$i];
6775             }
6776             }
6777              
6778 0         0 $delimiter = '/';
6779 0         0 $end_delimiter = '/';
6780 0         0 my $prematch = '';
6781 0         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 16     16 0 25 my($ope,$delimiter,$end_delimiter,$string) = @_;
6789              
6790 16         18 $slash = 'div';
6791              
6792 16         128 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6793 16         47 for (my $i=0; $i <= $#char; $i++) {
6794 9 100       34 if (0) {
    100          
6795             }
6796              
6797             # not escape \\
6798 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6799             }
6800              
6801             # escape $ @ / and \
6802             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6803 5         16 $char[$i] = '\\' . $char[$i];
6804             }
6805             }
6806              
6807 16         50 return join '', $ope, $delimiter, @char, $end_delimiter;
6808             }
6809              
6810             #
6811             # escape regexp (s/here/and here/modifier)
6812             #
6813             sub e_sub {
6814 97     97 0 504 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6815 97   100     367 $modifier ||= '';
6816              
6817 97         179 $modifier =~ tr/p//d;
6818 97 50       307 if ($modifier =~ /([adlu])/oxms) {
6819 0         0 my $line = 0;
6820 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6821 0 0       0 if ($filename ne __FILE__) {
6822 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6823 0         0 last;
6824             }
6825             }
6826 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6827             }
6828              
6829 97 100       236 if ($variable eq '') {
6830 36         34 $variable = '$_';
6831 36         49 $bind_operator = ' =~ ';
6832             }
6833              
6834 97         125 $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 97         135 my $e_modifier = $modifier =~ tr/e//d;
6852 97         118 my $r_modifier = $modifier =~ tr/r//d;
6853              
6854 97         119 my $my = '';
6855 97 50       248 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6856 0         0 $my = $variable;
6857 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6858 0         0 $variable =~ s/ = .+ \z//oxms;
6859             }
6860              
6861 97         212 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6862 97         198 $variable_basename =~ s/ \s+ \z//oxms;
6863              
6864             # quote replacement string
6865 97         116 my $e_replacement = '';
6866 97 100       211 if ($e_modifier >= 1) {
6867 17         37 $e_replacement = e_qq('', '', '', $replacement);
6868 17         27 $e_modifier--;
6869             }
6870             else {
6871 80 100       161 if ($delimiter2 eq "'") {
6872 16         33 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6873             }
6874             else {
6875 64         161 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6876             }
6877             }
6878              
6879 97         138 my $sub = '';
6880              
6881             # with /r
6882 97 100       203 if ($r_modifier) {
6883 8 100       25 if (0) {
6884             }
6885              
6886             # s///gr without multibyte anchoring
6887 0         0 elsif ($modifier =~ /g/oxms) {
6888 4 50       22 $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             '$Latin8::re_r=CORE::eval $Latin8::re_r; ' x $e_modifier, # 5
6899             );
6900             }
6901              
6902             # s///r
6903             else {
6904              
6905 4         4 my $prematch = q{$`};
6906              
6907 4 50       28 $sub = sprintf(
6908             # 1 2 3 4 5 6 7
6909             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin8::re_r=%s; %s"%s$Latin8::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             '$Latin8::re_r=CORE::eval $Latin8::re_r; ' x $e_modifier, # 5
6918             $prematch, # 6
6919             $variable, # 7
6920             );
6921             }
6922              
6923             # $var !~ s///r doesn't make sense
6924 8 50       22 if ($bind_operator =~ / !~ /oxms) {
6925 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6926             }
6927             }
6928              
6929             # without /r
6930             else {
6931 89 100       198 if (0) {
6932             }
6933              
6934             # s///g without multibyte anchoring
6935 0         0 elsif ($modifier =~ /g/oxms) {
6936 22 100       107 $sub = sprintf(
    100          
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             '$Latin8::re_r=CORE::eval $Latin8::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 67         114 my $prematch = q{$`};
6957              
6958 67 100       392 $sub = sprintf(
    100          
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 $Latin8::re_r=%s; %s%s="%s$Latin8::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 $Latin8::re_r=%s; %s%s="%s$Latin8::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             '$Latin8::re_r=CORE::eval $Latin8::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 97 50       281 if ($my ne '') {
6984 0         0 $sub = "($my, $sub)[1]";
6985             }
6986              
6987             # clear s/// variable
6988 97         126 $sub_variable = '';
6989 97         101 $bind_operator = '';
6990              
6991 97         715 return $sub;
6992             }
6993              
6994             #
6995             # escape regexp of split qr//
6996             #
6997             sub e_split {
6998 74     74 0 242 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6999 74   100     348 $modifier ||= '';
7000              
7001 74         381 $modifier =~ tr/p//d;
7002 74 50       324 if ($modifier =~ /([adlu])/oxms) {
7003 0         0 my $line = 0;
7004 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7005 0 0       0 if ($filename ne __FILE__) {
7006 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7007 0         0 last;
7008             }
7009             }
7010 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
7011             }
7012              
7013 74         112 $slash = 'div';
7014              
7015             # /b /B modifier
7016 74 50       175 if ($modifier =~ tr/bB//d) {
7017 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7018             }
7019              
7020 74 50       164 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7021 74         334 my $metachar = qr/[\@\\|[\]{^]/oxms;
7022              
7023             # split regexp
7024 74         9674 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 74         263 my $left_e = 0;
7049 74         96 my $right_e = 0;
7050 74         291 for (my $i=0; $i <= $#char; $i++) {
7051              
7052             # "\L\u" --> "\u\L"
7053 249 50 33     1624 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7054 0         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         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 1         3 $char[$i] = Elatin8::octchr($1);
7065             }
7066              
7067             # hexadecimal escape sequence
7068             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7069 1         3 $char[$i] = Elatin8::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         0 $char[$i] = $1 . '\\' . $2;
7079             }
7080              
7081             # \p, \P, \X --> p, P, X
7082             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7083 0         0 $char[$i] = $1;
7084             }
7085              
7086 249 50 100     957 if (0) {
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7087             }
7088              
7089             # join separated multiple-octet
7090 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7091 0 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         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         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         0 $char[$i] .= join '', splice @char, $i+1, 1;
7099             }
7100             }
7101              
7102             # open character class [...]
7103             elsif ($char[$i] eq '[') {
7104 3         5 my $left = $i;
7105 3 50       12 if ($char[$i+1] eq ']') {
7106 0         0 $i++;
7107             }
7108 3         3 while (1) {
7109 7 50       22 if (++$i > $#char) {
7110 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7111             }
7112 7 100       18 if ($char[$i] eq ']') {
7113 3         4 my $right = $i;
7114              
7115             # [...]
7116 3 50       23 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7117 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7118             }
7119             else {
7120 3         17 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
7121             }
7122              
7123 3         5 $i = $left;
7124 3         10 last;
7125             }
7126             }
7127             }
7128              
7129             # open character class [^...]
7130             elsif ($char[$i] eq '[^') {
7131 0         0 my $left = $i;
7132 0 0       0 if ($char[$i+1] eq ']') {
7133 0         0 $i++;
7134             }
7135 0         0 while (1) {
7136 0 0       0 if (++$i > $#char) {
7137 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7138             }
7139 0 0       0 if ($char[$i] eq ']') {
7140 0         0 my $right = $i;
7141              
7142             # [^...]
7143 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7144 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7145             }
7146             else {
7147 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7148             }
7149              
7150 0         0 $i = $left;
7151 0         0 last;
7152             }
7153             }
7154             }
7155              
7156             # rewrite character class or escape character
7157             elsif (my $char = character_class($char[$i],$modifier)) {
7158 1         3 $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 7         48 $modifier .= 'm';
7176             }
7177              
7178             # /i modifier
7179             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
7180 0 0       0 if (CORE::length(Elatin8::fc($char[$i])) == 1) {
7181 0         0 $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
7182             }
7183             else {
7184 0         0 $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
7185             }
7186             }
7187              
7188             # \u \l \U \L \F \Q \E
7189             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7190 0 0       0 if ($right_e < $left_e) {
7191 0         0 $char[$i] = '\\' . $char[$i];
7192             }
7193             }
7194             elsif ($char[$i] eq '\u') {
7195 0         0 $char[$i] = '@{[Elatin8::ucfirst qq<';
7196 0         0 $left_e++;
7197             }
7198             elsif ($char[$i] eq '\l') {
7199 0         0 $char[$i] = '@{[Elatin8::lcfirst qq<';
7200 0         0 $left_e++;
7201             }
7202             elsif ($char[$i] eq '\U') {
7203 0         0 $char[$i] = '@{[Elatin8::uc qq<';
7204 0         0 $left_e++;
7205             }
7206             elsif ($char[$i] eq '\L') {
7207 0         0 $char[$i] = '@{[Elatin8::lc qq<';
7208 0         0 $left_e++;
7209             }
7210             elsif ($char[$i] eq '\F') {
7211 0         0 $char[$i] = '@{[Elatin8::fc qq<';
7212 0         0 $left_e++;
7213             }
7214             elsif ($char[$i] eq '\Q') {
7215 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7216 0         0 $left_e++;
7217             }
7218             elsif ($char[$i] eq '\E') {
7219 0 0       0 if ($right_e < $left_e) {
7220 0         0 $char[$i] = '>]}';
7221 0         0 $right_e++;
7222             }
7223             else {
7224 0         0 $char[$i] = '';
7225             }
7226             }
7227             elsif ($char[$i] eq '\Q') {
7228 0         0 while (1) {
7229 0 0       0 if (++$i > $#char) {
7230 0         0 last;
7231             }
7232 0 0       0 if ($char[$i] eq '\E') {
7233 0         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       0 if ($ignorecase) {
7243 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7244             }
7245             }
7246             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7247 0 0       0 if ($ignorecase) {
7248 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
7260 0 0       0 if ($ignorecase) {
7261 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7262             }
7263             }
7264             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7265 0         0 $char[$i] = e_capture($1);
7266 0 0       0 if ($ignorecase) {
7267 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1.'->'.$2);
7274 0 0       0 if ($ignorecase) {
7275 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1.'->'.$2);
7282 0 0       0 if ($ignorecase) {
7283 0         0 $char[$i] = '@{[Elatin8::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         0 $char[$i] = e_capture($1);
7290 0 0       0 if ($ignorecase) {
7291 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7292             }
7293             }
7294              
7295             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
7296             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7297 12 50       29 if ($ignorecase) {
7298 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
7299             }
7300             else {
7301 12         93 $char[$i] = '@{[Elatin8::PREMATCH()]}';
7302             }
7303             }
7304              
7305             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
7306             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7307 12 50       24 if ($ignorecase) {
7308 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
7309             }
7310             else {
7311 12         91 $char[$i] = '@{[Elatin8::MATCH()]}';
7312             }
7313             }
7314              
7315             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
7316             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7317 9 50       15 if ($ignorecase) {
7318 0         0 $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
7319             }
7320             else {
7321 9         57 $char[$i] = '@{[Elatin8::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       0 if ($ignorecase) {
7328 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $1 . ')]}';
7329             }
7330             }
7331              
7332             # ${ ... }
7333             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7334 0         0 $char[$i] = e_capture($1);
7335 0 0       0 if ($ignorecase) {
7336 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7337             }
7338             }
7339              
7340             # $scalar or @array
7341             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7342 3         6 $char[$i] = e_string($char[$i]);
7343 3 50       18 if ($ignorecase) {
7344 0         0 $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7345             }
7346             }
7347              
7348             # quote character before ? + * {
7349             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7350 1 50       14 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         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7354             }
7355             }
7356             }
7357              
7358             # make regexp string
7359 74         115 $modifier =~ tr/i//d;
7360 74 50       184 if ($left_e > $right_e) {
7361 0         0 return join '', 'Elatin8::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7362             }
7363 74         743 return join '', 'Elatin8::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, Elatin8::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, Elatin8::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 (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
7466 0 0         if (CORE::length(Elatin8::fc($char[$i])) == 1) {
7467 0           $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
7468             }
7469             else {
7470 0           $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::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 '', 'Elatin8::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__