File Coverage

Char/Elatin8.pm
Criterion Covered Total %
statement 83 3062 2.7
branch 4 2670 0.1
condition 1 373 0.2
subroutine 36 125 28.8
pod 7 74 9.4
total 131 6304 2.0


line stmt bran cond sub pod time code
1             #
2             # This file is *** FOR CPAN USE ONLY ***.
3             #
4             package Char::Elatin8;
5             ######################################################################
6             #
7             # Char::Elatin8 - Run-time routines for Char/Latin8.pm
8             #
9             # http://search.cpan.org/dist/Char-Latin8/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
12             ######################################################################
13              
14 197     197   4611 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         640  
  197         11693  
15             # use 5.008001; # Lancaster Consensus 2013 for toolchains
16              
17             # 12.3. Delaying use Until Runtime
18             # in Chapter 12. Packages, Libraries, and Modules
19             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
20             # (and so on)
21              
22 197     197   13891 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1231  
  197         357  
  197         35873  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 197 50   197   1363 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 197         282 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 197         31418 if (CORE::ord('A') != 0x41) {
33             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).";
34             }
35             }
36              
37             BEGIN {
38              
39             # instead of utf8.pm
40 197     197   13577 CORE::eval q{
  197     197   1176  
  197     66   377  
  197         38784  
  66         10088  
  72         12941  
  64         25397  
  59         10988  
  71         12541  
  62         23449  
41             no warnings qw(redefine);
42             *utf8::upgrade = sub { CORE::length $_[0] };
43             *utf8::downgrade = sub { 1 };
44             *utf8::encode = sub { };
45             *utf8::decode = sub { 1 };
46             *utf8::is_utf8 = sub { };
47             *utf8::valid = sub { 1 };
48             };
49 197 50       117153 if ($@) {
50 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
51 0         0 *utf8::downgrade = sub { 1 };
  0         0  
52 0         0 *utf8::encode = sub { };
  0         0  
53 0         0 *utf8::decode = sub { 1 };
  0         0  
54 0         0 *utf8::is_utf8 = sub { };
  0         0  
55 0         0 *utf8::valid = sub { 1 };
  0         0  
56             }
57             }
58              
59             # instead of Symbol.pm
60             BEGIN {
61 197     197   497 my $genpkg = "Symbol::";
62 197         9972 my $genseq = 0;
63              
64             sub gensym () {
65 0     0 0 0 my $name = "GEN" . $genseq++;
66              
67             # here, no strict qw(refs); if strict.pm exists
68              
69 0         0 my $ref = \*{$genpkg . $name};
  0         0  
70 0         0 delete $$genpkg{$name};
71 0         0 return $ref;
72             }
73              
74             sub qualify ($;$) {
75 0     0 0 0 my ($name) = @_;
76 0 0 0     0 if (!ref($name) && (Char::Elatin8::index($name, '::') == -1) && (Char::Elatin8::index($name, "'") == -1)) {
      0        
77 0         0 my $pkg;
78 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
79              
80             # Global names: special character, "^xyz", or other.
81 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
82             # RGS 2001-11-05 : translate leading ^X to control-char
83 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
84 0         0 $pkg = "main";
85             }
86             else {
87 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
88             }
89 0         0 $name = $pkg . "::" . $name;
90             }
91 0         0 return $name;
92             }
93              
94             sub qualify_to_ref ($;$) {
95              
96             # here, no strict qw(refs); if strict.pm exists
97              
98 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
99             }
100             }
101              
102             # Column: local $@
103             # in Chapter 9. Osaete okitai Perl no kiso
104             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
105             # (and so on)
106              
107             # use strict; if strict.pm exists
108             BEGIN {
109 197 50   197   402 if (CORE::eval { local $@; CORE::require strict }) {
  197         373  
  197         2362  
110 197         40350 strict::->import;
111             }
112             }
113              
114             # P.714 29.2.39. flock
115             # in Chapter 29: Functions
116             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
117              
118             # P.863 flock
119             # in Chapter 27: Functions
120             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
121              
122             sub LOCK_SH() {1}
123             sub LOCK_EX() {2}
124             sub LOCK_UN() {8}
125             sub LOCK_NB() {4}
126              
127             # instead of Carp.pm
128             sub carp;
129             sub croak;
130             sub cluck;
131             sub confess;
132              
133             # 6.18. Matching Multiple-Byte Characters
134             # in Chapter 6. Pattern Matching
135             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
136             # (and so on)
137              
138             # regexp of character
139 197     197   14029 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  197     197   1177  
  197         321  
  197         12559  
140 197     197   11397 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  197     197   1244  
  197         410  
  197         13956  
141 197     197   12337 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  197     197   1089  
  197         334  
  197         15061  
142              
143             #
144             # Latin-8 character range per length
145             #
146             my %range_tr = ();
147              
148             #
149             # alias of encoding name
150             #
151 197     197   12368 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  197     197   1291  
  197         957  
  197         460047  
152              
153             #
154             # Latin-8 case conversion
155             #
156             my %lc = ();
157             @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)} =
158             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);
159             my %uc = ();
160             @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)} =
161             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
162             my %fc = ();
163             @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)} =
164             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
165              
166             if (0) {
167             }
168              
169             elsif (__PACKAGE__ =~ / \b Elatin8 \z/oxms) {
170             %range_tr = (
171             1 => [ [0x00..0xFF],
172             ],
173             );
174             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-14 | iec[- ]?8859-14 | latin-?8 ) \b /oxmsi;
175              
176             %lc = (%lc,
177             "\xA1" => "\xA2", # LATIN LETTER B WITH DOT ABOVE
178             "\xA4" => "\xA5", # LATIN LETTER C WITH DOT ABOVE
179             "\xA6" => "\xAB", # LATIN LETTER D WITH DOT ABOVE
180             "\xA8" => "\xB8", # LATIN LETTER W WITH GRAVE
181             "\xAA" => "\xBA", # LATIN LETTER W WITH ACUTE
182             "\xAC" => "\xBC", # LATIN LETTER Y WITH GRAVE
183             "\xAF" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
184             "\xB0" => "\xB1", # LATIN LETTER F WITH DOT ABOVE
185             "\xB2" => "\xB3", # LATIN LETTER G WITH DOT ABOVE
186             "\xB4" => "\xB5", # LATIN LETTER M WITH DOT ABOVE
187             "\xB7" => "\xB9", # LATIN LETTER P WITH DOT ABOVE
188             "\xBB" => "\xBF", # LATIN LETTER S WITH DOT ABOVE
189             "\xBD" => "\xBE", # LATIN LETTER W WITH DIAERESIS
190             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
191             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
192             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
193             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
194             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
195             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
196             "\xC6" => "\xE6", # LATIN LETTER AE
197             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
198             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
199             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
200             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
201             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
202             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
203             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
204             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
205             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
206             "\xD0" => "\xF0", # LATIN LETTER W WITH CIRCUMFLEX
207             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
208             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
209             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
210             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
211             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
212             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
213             "\xD7" => "\xF7", # LATIN LETTER T WITH DOT ABOVE
214             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
215             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
216             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
217             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
218             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
219             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
220             "\xDE" => "\xFE", # LATIN LETTER Y WITH CIRCUMFLEX
221             );
222              
223             %uc = (%uc,
224             "\xA2" => "\xA1", # LATIN LETTER B WITH DOT ABOVE
225             "\xA5" => "\xA4", # LATIN LETTER C WITH DOT ABOVE
226             "\xAB" => "\xA6", # LATIN LETTER D WITH DOT ABOVE
227             "\xB1" => "\xB0", # LATIN LETTER F WITH DOT ABOVE
228             "\xB3" => "\xB2", # LATIN LETTER G WITH DOT ABOVE
229             "\xB5" => "\xB4", # LATIN LETTER M WITH DOT ABOVE
230             "\xB8" => "\xA8", # LATIN LETTER W WITH GRAVE
231             "\xB9" => "\xB7", # LATIN LETTER P WITH DOT ABOVE
232             "\xBA" => "\xAA", # LATIN LETTER W WITH ACUTE
233             "\xBC" => "\xAC", # LATIN LETTER Y WITH GRAVE
234             "\xBE" => "\xBD", # LATIN LETTER W WITH DIAERESIS
235             "\xBF" => "\xBB", # LATIN LETTER S WITH DOT ABOVE
236             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
237             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
238             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
239             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
240             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
241             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
242             "\xE6" => "\xC6", # LATIN LETTER AE
243             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
244             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
245             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
246             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
247             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
248             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
249             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
250             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
251             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
252             "\xF0" => "\xD0", # LATIN LETTER W WITH CIRCUMFLEX
253             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
254             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
255             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
256             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
257             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
258             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
259             "\xF7" => "\xD7", # LATIN LETTER T WITH DOT ABOVE
260             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
261             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
262             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
263             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
264             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
265             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
266             "\xFE" => "\xDE", # LATIN LETTER Y WITH CIRCUMFLEX
267             "\xFF" => "\xAF", # LATIN LETTER Y WITH DIAERESIS
268             );
269              
270             %fc = (%fc,
271             "\xA1" => "\xA2", # LATIN CAPITAL LETTER B WITH DOT ABOVE --> LATIN SMALL LETTER B WITH DOT ABOVE
272             "\xA4" => "\xA5", # LATIN CAPITAL LETTER C WITH DOT ABOVE --> LATIN SMALL LETTER C WITH DOT ABOVE
273             "\xA6" => "\xAB", # LATIN CAPITAL LETTER D WITH DOT ABOVE --> LATIN SMALL LETTER D WITH DOT ABOVE
274             "\xA8" => "\xB8", # LATIN CAPITAL LETTER W WITH GRAVE --> LATIN SMALL LETTER W WITH GRAVE
275             "\xAA" => "\xBA", # LATIN CAPITAL LETTER W WITH ACUTE --> LATIN SMALL LETTER W WITH ACUTE
276             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Y WITH GRAVE --> LATIN SMALL LETTER Y WITH GRAVE
277             "\xAF" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
278             "\xB0" => "\xB1", # LATIN CAPITAL LETTER F WITH DOT ABOVE --> LATIN SMALL LETTER F WITH DOT ABOVE
279             "\xB2" => "\xB3", # LATIN CAPITAL LETTER G WITH DOT ABOVE --> LATIN SMALL LETTER G WITH DOT ABOVE
280             "\xB4" => "\xB5", # LATIN CAPITAL LETTER M WITH DOT ABOVE --> LATIN SMALL LETTER M WITH DOT ABOVE
281             "\xB7" => "\xB9", # LATIN CAPITAL LETTER P WITH DOT ABOVE --> LATIN SMALL LETTER P WITH DOT ABOVE
282             "\xBB" => "\xBF", # LATIN CAPITAL LETTER S WITH DOT ABOVE --> LATIN SMALL LETTER S WITH DOT ABOVE
283             "\xBD" => "\xBE", # LATIN CAPITAL LETTER W WITH DIAERESIS --> LATIN SMALL LETTER W WITH DIAERESIS
284             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
285             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
286             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
287             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
288             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
289             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
290             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
291             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
292             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
293             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
294             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
295             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
296             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
297             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
298             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
299             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
300             "\xD0" => "\xF0", # LATIN CAPITAL LETTER W WITH CIRCUMFLEX --> LATIN SMALL LETTER W WITH CIRCUMFLEX
301             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
302             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
303             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
304             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
305             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
306             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
307             "\xD7" => "\xF7", # LATIN CAPITAL LETTER T WITH DOT ABOVE --> LATIN SMALL LETTER T WITH DOT ABOVE
308             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
309             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
310             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
311             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
312             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
313             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
314             "\xDE" => "\xFE", # LATIN CAPITAL LETTER Y WITH CIRCUMFLEX --> LATIN SMALL LETTER Y WITH CIRCUMFLEX
315             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
316             );
317             }
318              
319             else {
320             croak "Don't know my package name '@{[__PACKAGE__]}'";
321             }
322              
323             #
324             # @ARGV wildcard globbing
325             #
326             sub import {
327              
328 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
329 0         0 my @argv = ();
330 0         0 for (@ARGV) {
331              
332             # has space
333 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
334 0 0       0 if (my @glob = Char::Elatin8::glob(qq{"$_"})) {
335 0         0 push @argv, @glob;
336             }
337             else {
338 0         0 push @argv, $_;
339             }
340             }
341              
342             # has wildcard metachar
343             elsif (/\A (?:$q_char)*? [*?] /oxms) {
344 0 0       0 if (my @glob = Char::Elatin8::glob($_)) {
345 0         0 push @argv, @glob;
346             }
347             else {
348 0         0 push @argv, $_;
349             }
350             }
351              
352             # no wildcard globbing
353             else {
354 0         0 push @argv, $_;
355             }
356             }
357 0         0 @ARGV = @argv;
358             }
359             }
360              
361             # P.230 Care with Prototypes
362             # in Chapter 6: Subroutines
363             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
364             #
365             # If you aren't careful, you can get yourself into trouble with prototypes.
366             # But if you are careful, you can do a lot of neat things with them. This is
367             # all very powerful, of course, and should only be used in moderation to make
368             # the world a better place.
369              
370             # P.332 Care with Prototypes
371             # in Chapter 7: Subroutines
372             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
373             #
374             # If you aren't careful, you can get yourself into trouble with prototypes.
375             # But if you are careful, you can do a lot of neat things with them. This is
376             # all very powerful, of course, and should only be used in moderation to make
377             # the world a better place.
378              
379             #
380             # Prototypes of subroutines
381             #
382 0     0   0 sub unimport {}
383             sub Char::Elatin8::split(;$$$);
384             sub Char::Elatin8::tr($$$$;$);
385             sub Char::Elatin8::chop(@);
386             sub Char::Elatin8::index($$;$);
387             sub Char::Elatin8::rindex($$;$);
388             sub Char::Elatin8::lcfirst(@);
389             sub Char::Elatin8::lcfirst_();
390             sub Char::Elatin8::lc(@);
391             sub Char::Elatin8::lc_();
392             sub Char::Elatin8::ucfirst(@);
393             sub Char::Elatin8::ucfirst_();
394             sub Char::Elatin8::uc(@);
395             sub Char::Elatin8::uc_();
396             sub Char::Elatin8::fc(@);
397             sub Char::Elatin8::fc_();
398             sub Char::Elatin8::ignorecase;
399             sub Char::Elatin8::classic_character_class;
400             sub Char::Elatin8::capture;
401             sub Char::Elatin8::chr(;$);
402             sub Char::Elatin8::chr_();
403             sub Char::Elatin8::glob($);
404             sub Char::Elatin8::glob_();
405              
406             sub Char::Latin8::ord(;$);
407             sub Char::Latin8::ord_();
408             sub Char::Latin8::reverse(@);
409             sub Char::Latin8::getc(;*@);
410             sub Char::Latin8::length(;$);
411             sub Char::Latin8::substr($$;$$);
412             sub Char::Latin8::index($$;$);
413             sub Char::Latin8::rindex($$;$);
414             sub Char::Latin8::escape(;$);
415              
416             #
417             # Regexp work
418             #
419 197     197   16221 BEGIN { CORE::eval q{ use vars qw(
  197     197   1527  
  197         330  
  197         92157  
420             $Char::Latin8::re_a
421             $Char::Latin8::re_t
422             $Char::Latin8::re_n
423             $Char::Latin8::re_r
424             ) } }
425              
426             #
427             # Character class
428             #
429 197     197   15670 BEGIN { CORE::eval q{ use vars qw(
  197     197   1149  
  197         353  
  197         3276234  
430             $dot
431             $dot_s
432             $eD
433             $eS
434             $eW
435             $eH
436             $eV
437             $eR
438             $eN
439             $not_alnum
440             $not_alpha
441             $not_ascii
442             $not_blank
443             $not_cntrl
444             $not_digit
445             $not_graph
446             $not_lower
447             $not_lower_i
448             $not_print
449             $not_punct
450             $not_space
451             $not_upper
452             $not_upper_i
453             $not_word
454             $not_xdigit
455             $eb
456             $eB
457             ) } }
458              
459             ${Char::Elatin8::dot} = qr{(?:[^\x0A])};
460             ${Char::Elatin8::dot_s} = qr{(?:[\x00-\xFF])};
461             ${Char::Elatin8::eD} = qr{(?:[^0-9])};
462              
463             # Vertical tabs are now whitespace
464             # \s in a regex now matches a vertical tab in all circumstances.
465             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
466             # ${Char::Elatin8::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
467             # ${Char::Elatin8::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
468             ${Char::Elatin8::eS} = qr{(?:[^\s])};
469              
470             ${Char::Elatin8::eW} = qr{(?:[^0-9A-Z_a-z])};
471             ${Char::Elatin8::eH} = qr{(?:[^\x09\x20])};
472             ${Char::Elatin8::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
473             ${Char::Elatin8::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
474             ${Char::Elatin8::eN} = qr{(?:[^\x0A])};
475             ${Char::Elatin8::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
476             ${Char::Elatin8::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
477             ${Char::Elatin8::not_ascii} = qr{(?:[^\x00-\x7F])};
478             ${Char::Elatin8::not_blank} = qr{(?:[^\x09\x20])};
479             ${Char::Elatin8::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
480             ${Char::Elatin8::not_digit} = qr{(?:[^\x30-\x39])};
481             ${Char::Elatin8::not_graph} = qr{(?:[^\x21-\x7F])};
482             ${Char::Elatin8::not_lower} = qr{(?:[^\x61-\x7A])};
483             ${Char::Elatin8::not_lower_i} = qr{(?:[\x00-\xFF])};
484             ${Char::Elatin8::not_print} = qr{(?:[^\x20-\x7F])};
485             ${Char::Elatin8::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
486             ${Char::Elatin8::not_space} = qr{(?:[^\s\x0B])};
487             ${Char::Elatin8::not_upper} = qr{(?:[^\x41-\x5A])};
488             ${Char::Elatin8::not_upper_i} = qr{(?:[\x00-\xFF])};
489             ${Char::Elatin8::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
490             ${Char::Elatin8::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
491             ${Char::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))};
492             ${Char::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]))};
493              
494             # avoid: Name "Char::Elatin8::foo" used only once: possible typo at here.
495             ${Char::Elatin8::dot} = ${Char::Elatin8::dot};
496             ${Char::Elatin8::dot_s} = ${Char::Elatin8::dot_s};
497             ${Char::Elatin8::eD} = ${Char::Elatin8::eD};
498             ${Char::Elatin8::eS} = ${Char::Elatin8::eS};
499             ${Char::Elatin8::eW} = ${Char::Elatin8::eW};
500             ${Char::Elatin8::eH} = ${Char::Elatin8::eH};
501             ${Char::Elatin8::eV} = ${Char::Elatin8::eV};
502             ${Char::Elatin8::eR} = ${Char::Elatin8::eR};
503             ${Char::Elatin8::eN} = ${Char::Elatin8::eN};
504             ${Char::Elatin8::not_alnum} = ${Char::Elatin8::not_alnum};
505             ${Char::Elatin8::not_alpha} = ${Char::Elatin8::not_alpha};
506             ${Char::Elatin8::not_ascii} = ${Char::Elatin8::not_ascii};
507             ${Char::Elatin8::not_blank} = ${Char::Elatin8::not_blank};
508             ${Char::Elatin8::not_cntrl} = ${Char::Elatin8::not_cntrl};
509             ${Char::Elatin8::not_digit} = ${Char::Elatin8::not_digit};
510             ${Char::Elatin8::not_graph} = ${Char::Elatin8::not_graph};
511             ${Char::Elatin8::not_lower} = ${Char::Elatin8::not_lower};
512             ${Char::Elatin8::not_lower_i} = ${Char::Elatin8::not_lower_i};
513             ${Char::Elatin8::not_print} = ${Char::Elatin8::not_print};
514             ${Char::Elatin8::not_punct} = ${Char::Elatin8::not_punct};
515             ${Char::Elatin8::not_space} = ${Char::Elatin8::not_space};
516             ${Char::Elatin8::not_upper} = ${Char::Elatin8::not_upper};
517             ${Char::Elatin8::not_upper_i} = ${Char::Elatin8::not_upper_i};
518             ${Char::Elatin8::not_word} = ${Char::Elatin8::not_word};
519             ${Char::Elatin8::not_xdigit} = ${Char::Elatin8::not_xdigit};
520             ${Char::Elatin8::eb} = ${Char::Elatin8::eb};
521             ${Char::Elatin8::eB} = ${Char::Elatin8::eB};
522              
523             #
524             # Latin-8 split
525             #
526             sub Char::Elatin8::split(;$$$) {
527              
528             # P.794 29.2.161. split
529             # in Chapter 29: Functions
530             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
531              
532             # P.951 split
533             # in Chapter 27: Functions
534             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
535              
536 0     0 0 0 my $pattern = $_[0];
537 0         0 my $string = $_[1];
538 0         0 my $limit = $_[2];
539              
540             # if $pattern is also omitted or is the literal space, " "
541 0 0       0 if (not defined $pattern) {
542 0         0 $pattern = ' ';
543             }
544              
545             # if $string is omitted, the function splits the $_ string
546 0 0       0 if (not defined $string) {
547 0 0       0 if (defined $_) {
548 0         0 $string = $_;
549             }
550             else {
551 0         0 $string = '';
552             }
553             }
554              
555 0         0 my @split = ();
556              
557             # when string is empty
558 0 0       0 if ($string eq '') {
    0          
559              
560             # resulting list value in list context
561 0 0       0 if (wantarray) {
562 0         0 return @split;
563             }
564              
565             # count of substrings in scalar context
566             else {
567 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
568 0         0 @_ = @split;
569 0         0 return scalar @_;
570             }
571             }
572              
573             # split's first argument is more consistently interpreted
574             #
575             # After some changes earlier in v5.17, split's behavior has been simplified:
576             # if the PATTERN argument evaluates to a string containing one space, it is
577             # treated the way that a literal string containing one space once was.
578             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
579              
580             # if $pattern is also omitted or is the literal space, " ", the function splits
581             # on whitespace, /\s+/, after skipping any leading whitespace
582             # (and so on)
583              
584             elsif ($pattern eq ' ') {
585 0 0       0 if (not defined $limit) {
586 0         0 return CORE::split(' ', $string);
587             }
588             else {
589 0         0 return CORE::split(' ', $string, $limit);
590             }
591             }
592              
593             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
594 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
595              
596             # a pattern capable of matching either the null string or something longer than the
597             # null string will split the value of $string into separate characters wherever it
598             # matches the null string between characters
599             # (and so on)
600              
601 0 0       0 if ('' =~ / \A $pattern \z /xms) {
602 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
603 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
604              
605             # P.1024 Appendix W.10 Multibyte Processing
606             # of ISBN 1-56592-224-7 CJKV Information Processing
607             # (and so on)
608              
609             # the //m modifier is assumed when you split on the pattern /^/
610             # (and so on)
611              
612             # V
613 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
614              
615             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
616             # is included in the resulting list, interspersed with the fields that are ordinarily returned
617             # (and so on)
618              
619 0         0 local $@;
620 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
621 0         0 push @split, CORE::eval('$' . $digit);
622             }
623             }
624             }
625              
626             else {
627 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
628              
629             # V
630 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
631 0         0 local $@;
632 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
633 0         0 push @split, CORE::eval('$' . $digit);
634             }
635             }
636             }
637             }
638              
639             elsif ($limit > 0) {
640 0 0       0 if ('' =~ / \A $pattern \z /xms) {
641 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
642 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
643              
644             # V
645 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
646 0         0 local $@;
647 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
648 0         0 push @split, CORE::eval('$' . $digit);
649             }
650             }
651             }
652             }
653             else {
654 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
655 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
656              
657             # V
658 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
659 0         0 local $@;
660 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
661 0         0 push @split, CORE::eval('$' . $digit);
662             }
663             }
664             }
665             }
666             }
667              
668 0 0       0 if (CORE::length($string) > 0) {
669 0         0 push @split, $string;
670             }
671              
672             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
673 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
674 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
675 0         0 pop @split;
676             }
677             }
678              
679             # resulting list value in list context
680 0 0       0 if (wantarray) {
681 0         0 return @split;
682             }
683              
684             # count of substrings in scalar context
685             else {
686 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
687 0         0 @_ = @split;
688 0         0 return scalar @_;
689             }
690             }
691              
692             #
693             # get last subexpression offsets
694             #
695             sub _last_subexpression_offsets {
696 0     0   0 my $pattern = $_[0];
697              
698             # remove comment
699 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
700              
701 0         0 my $modifier = '';
702 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
703 0         0 $modifier = $1;
704 0         0 $modifier =~ s/-[A-Za-z]*//;
705             }
706              
707             # with /x modifier
708 0         0 my @char = ();
709 0 0       0 if ($modifier =~ /x/oxms) {
710 0         0 @char = $pattern =~ /\G(
711             \\ (?:$q_char) |
712             \# (?:$q_char)*? $ |
713             \[ (?: \\\] | (?:$q_char))+? \] |
714             \(\? |
715             (?:$q_char)
716             )/oxmsg;
717             }
718              
719             # without /x modifier
720             else {
721 0         0 @char = $pattern =~ /\G(
722             \\ (?:$q_char) |
723             \[ (?: \\\] | (?:$q_char))+? \] |
724             \(\? |
725             (?:$q_char)
726             )/oxmsg;
727             }
728              
729 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
730             }
731              
732             #
733             # Latin-8 transliteration (tr///)
734             #
735             sub Char::Elatin8::tr($$$$;$) {
736              
737 0     0 0 0 my $bind_operator = $_[1];
738 0         0 my $searchlist = $_[2];
739 0         0 my $replacementlist = $_[3];
740 0   0     0 my $modifier = $_[4] || '';
741              
742 0 0       0 if ($modifier =~ /r/oxms) {
743 0 0       0 if ($bind_operator =~ / !~ /oxms) {
744 0         0 croak "Using !~ with tr///r doesn't make sense";
745             }
746             }
747              
748 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
749 0         0 my @searchlist = _charlist_tr($searchlist);
750 0         0 my @replacementlist = _charlist_tr($replacementlist);
751              
752 0         0 my %tr = ();
753 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
754 0 0       0 if (not exists $tr{$searchlist[$i]}) {
755 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
756 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
757             }
758             elsif ($modifier =~ /d/oxms) {
759 0         0 $tr{$searchlist[$i]} = '';
760             }
761             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
762 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
763             }
764             else {
765 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
766             }
767             }
768             }
769              
770 0         0 my $tr = 0;
771 0         0 my $replaced = '';
772 0 0       0 if ($modifier =~ /c/oxms) {
773 0         0 while (defined(my $char = shift @char)) {
774 0 0       0 if (not exists $tr{$char}) {
775 0 0       0 if (defined $replacementlist[0]) {
776 0         0 $replaced .= $replacementlist[0];
777             }
778 0         0 $tr++;
779 0 0       0 if ($modifier =~ /s/oxms) {
780 0   0     0 while (@char and (not exists $tr{$char[0]})) {
781 0         0 shift @char;
782 0         0 $tr++;
783             }
784             }
785             }
786             else {
787 0         0 $replaced .= $char;
788             }
789             }
790             }
791             else {
792 0         0 while (defined(my $char = shift @char)) {
793 0 0       0 if (exists $tr{$char}) {
794 0         0 $replaced .= $tr{$char};
795 0         0 $tr++;
796 0 0       0 if ($modifier =~ /s/oxms) {
797 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
798 0         0 shift @char;
799 0         0 $tr++;
800             }
801             }
802             }
803             else {
804 0         0 $replaced .= $char;
805             }
806             }
807             }
808              
809 0 0       0 if ($modifier =~ /r/oxms) {
810 0         0 return $replaced;
811             }
812             else {
813 0         0 $_[0] = $replaced;
814 0 0       0 if ($bind_operator =~ / !~ /oxms) {
815 0         0 return not $tr;
816             }
817             else {
818 0         0 return $tr;
819             }
820             }
821             }
822              
823             #
824             # Latin-8 chop
825             #
826             sub Char::Elatin8::chop(@) {
827              
828 0     0 0 0 my $chop;
829 0 0       0 if (@_ == 0) {
830 0         0 my @char = /\G ($q_char) /oxmsg;
831 0         0 $chop = pop @char;
832 0         0 $_ = join '', @char;
833             }
834             else {
835 0         0 for (@_) {
836 0         0 my @char = /\G ($q_char) /oxmsg;
837 0         0 $chop = pop @char;
838 0         0 $_ = join '', @char;
839             }
840             }
841 0         0 return $chop;
842             }
843              
844             #
845             # Latin-8 index by octet
846             #
847             sub Char::Elatin8::index($$;$) {
848              
849 0     0 1 0 my($str,$substr,$position) = @_;
850 0   0     0 $position ||= 0;
851 0         0 my $pos = 0;
852              
853 0         0 while ($pos < CORE::length($str)) {
854 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
855 0 0       0 if ($pos >= $position) {
856 0         0 return $pos;
857             }
858             }
859 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
860 0         0 $pos += CORE::length($1);
861             }
862             else {
863 0         0 $pos += 1;
864             }
865             }
866 0         0 return -1;
867             }
868              
869             #
870             # Latin-8 reverse index
871             #
872             sub Char::Elatin8::rindex($$;$) {
873              
874 0     0 0 0 my($str,$substr,$position) = @_;
875 0   0     0 $position ||= CORE::length($str) - 1;
876 0         0 my $pos = 0;
877 0         0 my $rindex = -1;
878              
879 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
880 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
881 0         0 $rindex = $pos;
882             }
883 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
884 0         0 $pos += CORE::length($1);
885             }
886             else {
887 0         0 $pos += 1;
888             }
889             }
890 0         0 return $rindex;
891             }
892              
893             #
894             # Latin-8 lower case first with parameter
895             #
896             sub Char::Elatin8::lcfirst(@) {
897 0 0   0 0 0 if (@_) {
898 0         0 my $s = shift @_;
899 0 0 0     0 if (@_ and wantarray) {
900 0         0 return Char::Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
901             }
902             else {
903 0         0 return Char::Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
904             }
905             }
906             else {
907 0         0 return Char::Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
908             }
909             }
910              
911             #
912             # Latin-8 lower case first without parameter
913             #
914             sub Char::Elatin8::lcfirst_() {
915 0     0 0 0 return Char::Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
916             }
917              
918             #
919             # Latin-8 lower case with parameter
920             #
921             sub Char::Elatin8::lc(@) {
922 0 0   0 0 0 if (@_) {
923 0         0 my $s = shift @_;
924 0 0 0     0 if (@_ and wantarray) {
925 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
926             }
927             else {
928 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
929             }
930             }
931             else {
932 0         0 return Char::Elatin8::lc_();
933             }
934             }
935              
936             #
937             # Latin-8 lower case without parameter
938             #
939             sub Char::Elatin8::lc_() {
940 0     0 0 0 my $s = $_;
941 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
942             }
943              
944             #
945             # Latin-8 upper case first with parameter
946             #
947             sub Char::Elatin8::ucfirst(@) {
948 0 0   0 0 0 if (@_) {
949 0         0 my $s = shift @_;
950 0 0 0     0 if (@_ and wantarray) {
951 0         0 return Char::Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
952             }
953             else {
954 0         0 return Char::Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
955             }
956             }
957             else {
958 0         0 return Char::Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
959             }
960             }
961              
962             #
963             # Latin-8 upper case first without parameter
964             #
965             sub Char::Elatin8::ucfirst_() {
966 0     0 0 0 return Char::Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
967             }
968              
969             #
970             # Latin-8 upper case with parameter
971             #
972             sub Char::Elatin8::uc(@) {
973 0 0   0 0 0 if (@_) {
974 0         0 my $s = shift @_;
975 0 0 0     0 if (@_ and wantarray) {
976 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
977             }
978             else {
979 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
980             }
981             }
982             else {
983 0         0 return Char::Elatin8::uc_();
984             }
985             }
986              
987             #
988             # Latin-8 upper case without parameter
989             #
990             sub Char::Elatin8::uc_() {
991 0     0 0 0 my $s = $_;
992 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
993             }
994              
995             #
996             # Latin-8 fold case with parameter
997             #
998             sub Char::Elatin8::fc(@) {
999 0 0   0 0 0 if (@_) {
1000 0         0 my $s = shift @_;
1001 0 0 0     0 if (@_ and wantarray) {
1002 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1003             }
1004             else {
1005 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1006             }
1007             }
1008             else {
1009 0         0 return Char::Elatin8::fc_();
1010             }
1011             }
1012              
1013             #
1014             # Latin-8 fold case without parameter
1015             #
1016             sub Char::Elatin8::fc_() {
1017 0     0 0 0 my $s = $_;
1018 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1019             }
1020              
1021             #
1022             # Latin-8 regexp capture
1023             #
1024             {
1025             sub Char::Elatin8::capture {
1026 0     0 1 0 return $_[0];
1027             }
1028             }
1029              
1030             #
1031             # Latin-8 regexp ignore case modifier
1032             #
1033             sub Char::Elatin8::ignorecase {
1034              
1035 0     0 0 0 my @string = @_;
1036 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1037              
1038             # ignore case of $scalar or @array
1039 0         0 for my $string (@string) {
1040              
1041             # split regexp
1042 0         0 my @char = $string =~ /\G(
1043             \[\^ |
1044             \\? (?:$q_char)
1045             )/oxmsg;
1046              
1047             # unescape character
1048 0         0 for (my $i=0; $i <= $#char; $i++) {
1049 0 0       0 next if not defined $char[$i];
1050              
1051             # open character class [...]
1052 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1053 0         0 my $left = $i;
1054              
1055             # [] make die "unmatched [] in regexp ..."
1056              
1057 0 0       0 if ($char[$i+1] eq ']') {
1058 0         0 $i++;
1059             }
1060              
1061 0         0 while (1) {
1062 0 0       0 if (++$i > $#char) {
1063 0         0 croak "Unmatched [] in regexp";
1064             }
1065 0 0       0 if ($char[$i] eq ']') {
1066 0         0 my $right = $i;
1067 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1068              
1069             # escape character
1070 0         0 for my $char (@charlist) {
1071 0 0       0 if (0) {
1072             }
1073              
1074 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1075 0         0 $char = $1 . '\\' . $char;
1076             }
1077             }
1078              
1079             # [...]
1080 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1081              
1082 0         0 $i = $left;
1083 0         0 last;
1084             }
1085             }
1086             }
1087              
1088             # open character class [^...]
1089             elsif ($char[$i] eq '[^') {
1090 0         0 my $left = $i;
1091              
1092             # [^] make die "unmatched [] in regexp ..."
1093              
1094 0 0       0 if ($char[$i+1] eq ']') {
1095 0         0 $i++;
1096             }
1097              
1098 0         0 while (1) {
1099 0 0       0 if (++$i > $#char) {
1100 0         0 croak "Unmatched [] in regexp";
1101             }
1102 0 0       0 if ($char[$i] eq ']') {
1103 0         0 my $right = $i;
1104 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1105              
1106             # escape character
1107 0         0 for my $char (@charlist) {
1108 0 0       0 if (0) {
1109             }
1110              
1111 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1112 0         0 $char = '\\' . $char;
1113             }
1114             }
1115              
1116             # [^...]
1117 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1118              
1119 0         0 $i = $left;
1120 0         0 last;
1121             }
1122             }
1123             }
1124              
1125             # rewrite classic character class or escape character
1126             elsif (my $char = classic_character_class($char[$i])) {
1127 0         0 $char[$i] = $char;
1128             }
1129              
1130             # with /i modifier
1131             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1132 0         0 my $uc = Char::Elatin8::uc($char[$i]);
1133 0         0 my $fc = Char::Elatin8::fc($char[$i]);
1134 0 0       0 if ($uc ne $fc) {
1135 0 0       0 if (CORE::length($fc) == 1) {
1136 0         0 $char[$i] = '[' . $uc . $fc . ']';
1137             }
1138             else {
1139 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1140             }
1141             }
1142             }
1143             }
1144              
1145             # characterize
1146 0         0 for (my $i=0; $i <= $#char; $i++) {
1147 0 0       0 next if not defined $char[$i];
1148              
1149 0 0       0 if (0) {
1150             }
1151              
1152             # quote character before ? + * {
1153 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1154 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1155 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1156             }
1157             }
1158             }
1159              
1160 0         0 $string = join '', @char;
1161             }
1162              
1163             # make regexp string
1164 0         0 return @string;
1165             }
1166              
1167             #
1168             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1169             #
1170             sub Char::Elatin8::classic_character_class {
1171 0     0 0 0 my($char) = @_;
1172              
1173             return {
1174 0   0     0 '\D' => '${Char::Elatin8::eD}',
1175             '\S' => '${Char::Elatin8::eS}',
1176             '\W' => '${Char::Elatin8::eW}',
1177             '\d' => '[0-9]',
1178              
1179             # Before Perl 5.6, \s only matched the five whitespace characters
1180             # tab, newline, form-feed, carriage return, and the space character
1181             # itself, which, taken together, is the character class [\t\n\f\r ].
1182              
1183             # Vertical tabs are now whitespace
1184             # \s in a regex now matches a vertical tab in all circumstances.
1185             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1186             # \t \n \v \f \r space
1187             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1188             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1189             '\s' => '\s',
1190              
1191             '\w' => '[0-9A-Z_a-z]',
1192             '\C' => '[\x00-\xFF]',
1193             '\X' => 'X',
1194              
1195             # \h \v \H \V
1196              
1197             # P.114 Character Class Shortcuts
1198             # in Chapter 7: In the World of Regular Expressions
1199             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1200              
1201             # P.357 13.2.3 Whitespace
1202             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1203             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1204             #
1205             # 0x00009 CHARACTER TABULATION h s
1206             # 0x0000a LINE FEED (LF) vs
1207             # 0x0000b LINE TABULATION v
1208             # 0x0000c FORM FEED (FF) vs
1209             # 0x0000d CARRIAGE RETURN (CR) vs
1210             # 0x00020 SPACE h s
1211              
1212             # P.196 Table 5-9. Alphanumeric regex metasymbols
1213             # in Chapter 5. Pattern Matching
1214             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1215              
1216             # (and so on)
1217              
1218             '\H' => '${Char::Elatin8::eH}',
1219             '\V' => '${Char::Elatin8::eV}',
1220             '\h' => '[\x09\x20]',
1221             '\v' => '[\x0A\x0B\x0C\x0D]',
1222             '\R' => '${Char::Elatin8::eR}',
1223              
1224             # \N
1225             #
1226             # http://perldoc.perl.org/perlre.html
1227             # Character Classes and other Special Escapes
1228             # Any character but \n (experimental). Not affected by /s modifier
1229              
1230             '\N' => '${Char::Elatin8::eN}',
1231              
1232             # \b \B
1233              
1234             # P.180 Boundaries: The \b and \B Assertions
1235             # in Chapter 5: Pattern Matching
1236             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1237              
1238             # P.219 Boundaries: The \b and \B Assertions
1239             # in Chapter 5: Pattern Matching
1240             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1241              
1242             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1243             '\b' => '${Char::Elatin8::eb}',
1244              
1245             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1246             '\B' => '${Char::Elatin8::eB}',
1247              
1248             }->{$char} || '';
1249             }
1250              
1251             #
1252             # prepare Latin-8 characters per length
1253             #
1254              
1255             # 1 octet characters
1256             my @chars1 = ();
1257             sub chars1 {
1258 0 0   0 0 0 if (@chars1) {
1259 0         0 return @chars1;
1260             }
1261 0 0       0 if (exists $range_tr{1}) {
1262 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1263 0         0 while (my @range = splice(@ranges,0,1)) {
1264 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1265 0         0 push @chars1, pack 'C', $oct0;
1266             }
1267             }
1268             }
1269 0         0 return @chars1;
1270             }
1271              
1272             # 2 octets characters
1273             my @chars2 = ();
1274             sub chars2 {
1275 0 0   0 0 0 if (@chars2) {
1276 0         0 return @chars2;
1277             }
1278 0 0       0 if (exists $range_tr{2}) {
1279 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1280 0         0 while (my @range = splice(@ranges,0,2)) {
1281 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1282 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1283 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1284             }
1285             }
1286             }
1287             }
1288 0         0 return @chars2;
1289             }
1290              
1291             # 3 octets characters
1292             my @chars3 = ();
1293             sub chars3 {
1294 0 0   0 0 0 if (@chars3) {
1295 0         0 return @chars3;
1296             }
1297 0 0       0 if (exists $range_tr{3}) {
1298 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1299 0         0 while (my @range = splice(@ranges,0,3)) {
1300 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1301 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1302 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1303 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1304             }
1305             }
1306             }
1307             }
1308             }
1309 0         0 return @chars3;
1310             }
1311              
1312             # 4 octets characters
1313             my @chars4 = ();
1314             sub chars4 {
1315 0 0   0 0 0 if (@chars4) {
1316 0         0 return @chars4;
1317             }
1318 0 0       0 if (exists $range_tr{4}) {
1319 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1320 0         0 while (my @range = splice(@ranges,0,4)) {
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 for my $oct3 (@{$range[3]}) {
  0         0  
1325 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1326             }
1327             }
1328             }
1329             }
1330             }
1331             }
1332 0         0 return @chars4;
1333             }
1334              
1335             #
1336             # Latin-8 open character list for tr
1337             #
1338             sub _charlist_tr {
1339              
1340 0     0   0 local $_ = shift @_;
1341              
1342             # unescape character
1343 0         0 my @char = ();
1344 0         0 while (not /\G \z/oxmsgc) {
1345 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1346 0         0 push @char, '\-';
1347             }
1348             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1349 0         0 push @char, CORE::chr(oct $1);
1350             }
1351             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1352 0         0 push @char, CORE::chr(hex $1);
1353             }
1354             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1355 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1356             }
1357             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1358 0         0 push @char, {
1359             '\0' => "\0",
1360             '\n' => "\n",
1361             '\r' => "\r",
1362             '\t' => "\t",
1363             '\f' => "\f",
1364             '\b' => "\x08", # \b means backspace in character class
1365             '\a' => "\a",
1366             '\e' => "\e",
1367             }->{$1};
1368             }
1369             elsif (/\G \\ ($q_char) /oxmsgc) {
1370 0         0 push @char, $1;
1371             }
1372             elsif (/\G ($q_char) /oxmsgc) {
1373 0         0 push @char, $1;
1374             }
1375             }
1376              
1377             # join separated multiple-octet
1378 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1379              
1380             # unescape '-'
1381 0         0 my @i = ();
1382 0         0 for my $i (0 .. $#char) {
1383 0 0       0 if ($char[$i] eq '\-') {
    0          
1384 0         0 $char[$i] = '-';
1385             }
1386             elsif ($char[$i] eq '-') {
1387 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1388 0         0 push @i, $i;
1389             }
1390             }
1391             }
1392              
1393             # open character list (reverse for splice)
1394 0         0 for my $i (CORE::reverse @i) {
1395 0         0 my @range = ();
1396              
1397             # range error
1398 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1399 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1400             }
1401              
1402             # range of multiple-octet code
1403 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1404 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1405 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1406             }
1407             elsif (CORE::length($char[$i+1]) == 2) {
1408 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1409 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1410             }
1411             elsif (CORE::length($char[$i+1]) == 3) {
1412 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1413 0         0 push @range, chars2();
1414 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1415             }
1416             elsif (CORE::length($char[$i+1]) == 4) {
1417 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1418 0         0 push @range, chars2();
1419 0         0 push @range, chars3();
1420 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1421             }
1422             else {
1423 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1424             }
1425             }
1426             elsif (CORE::length($char[$i-1]) == 2) {
1427 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1428 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1429             }
1430             elsif (CORE::length($char[$i+1]) == 3) {
1431 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1432 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1433             }
1434             elsif (CORE::length($char[$i+1]) == 4) {
1435 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1436 0         0 push @range, chars3();
1437 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1438             }
1439             else {
1440 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1441             }
1442             }
1443             elsif (CORE::length($char[$i-1]) == 3) {
1444 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1445 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1446             }
1447             elsif (CORE::length($char[$i+1]) == 4) {
1448 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1449 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1450             }
1451             else {
1452 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1453             }
1454             }
1455             elsif (CORE::length($char[$i-1]) == 4) {
1456 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1457 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1458             }
1459             else {
1460 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1461             }
1462             }
1463             else {
1464 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1465             }
1466              
1467 0         0 splice @char, $i-1, 3, @range;
1468             }
1469              
1470 0         0 return @char;
1471             }
1472              
1473             #
1474             # Latin-8 open character class
1475             #
1476             sub _cc {
1477 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1478 0         0 die __FILE__, ": subroutine cc got no parameter.";
1479             }
1480             elsif (scalar(@_) == 1) {
1481 0         0 return sprintf('\x%02X',$_[0]);
1482             }
1483             elsif (scalar(@_) == 2) {
1484 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1485 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1486             }
1487             elsif ($_[0] == $_[1]) {
1488 0         0 return sprintf('\x%02X',$_[0]);
1489             }
1490             elsif (($_[0]+1) == $_[1]) {
1491 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1492             }
1493             else {
1494 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1495             }
1496             }
1497             else {
1498 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1499             }
1500             }
1501              
1502             #
1503             # Latin-8 octet range
1504             #
1505             sub _octets {
1506 0     0   0 my $length = shift @_;
1507              
1508 0 0       0 if ($length == 1) {
1509 0         0 my($a1) = unpack 'C', $_[0];
1510 0         0 my($z1) = unpack 'C', $_[1];
1511              
1512 0 0       0 if ($a1 > $z1) {
1513 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1514             }
1515              
1516 0 0       0 if ($a1 == $z1) {
    0          
1517 0         0 return sprintf('\x%02X',$a1);
1518             }
1519             elsif (($a1+1) == $z1) {
1520 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1521             }
1522             else {
1523 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1524             }
1525             }
1526             else {
1527 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1528             }
1529             }
1530              
1531             #
1532             # Latin-8 range regexp
1533             #
1534             sub _range_regexp {
1535 0     0   0 my($length,$first,$last) = @_;
1536              
1537 0         0 my @range_regexp = ();
1538 0 0       0 if (not exists $range_tr{$length}) {
1539 0         0 return @range_regexp;
1540             }
1541              
1542 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1543 0         0 while (my @range = splice(@ranges,0,$length)) {
1544 0         0 my $min = '';
1545 0         0 my $max = '';
1546 0         0 for (my $i=0; $i < $length; $i++) {
1547 0         0 $min .= pack 'C', $range[$i][0];
1548 0         0 $max .= pack 'C', $range[$i][-1];
1549             }
1550              
1551             # min___max
1552             # FIRST_____________LAST
1553             # (nothing)
1554              
1555 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1556             }
1557              
1558             # **********
1559             # min_________max
1560             # FIRST_____________LAST
1561             # **********
1562              
1563             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1564 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1565             }
1566              
1567             # **********************
1568             # min________________max
1569             # FIRST_____________LAST
1570             # **********************
1571              
1572             elsif (($min eq $first) and ($max eq $last)) {
1573 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1574             }
1575              
1576             # *********
1577             # min___max
1578             # FIRST_____________LAST
1579             # *********
1580              
1581             elsif (($first le $min) and ($max le $last)) {
1582 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1583             }
1584              
1585             # **********************
1586             # min__________________________max
1587             # FIRST_____________LAST
1588             # **********************
1589              
1590             elsif (($min le $first) and ($last le $max)) {
1591 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1592             }
1593              
1594             # *********
1595             # min________max
1596             # FIRST_____________LAST
1597             # *********
1598              
1599             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1600 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1601             }
1602              
1603             # min___max
1604             # FIRST_____________LAST
1605             # (nothing)
1606              
1607             elsif ($last lt $min) {
1608             }
1609              
1610             else {
1611 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1612             }
1613             }
1614              
1615 0         0 return @range_regexp;
1616             }
1617              
1618             #
1619             # Latin-8 open character list for qr and not qr
1620             #
1621             sub _charlist {
1622              
1623 0     0   0 my $modifier = pop @_;
1624 0         0 my @char = @_;
1625              
1626 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1627              
1628             # unescape character
1629 0         0 for (my $i=0; $i <= $#char; $i++) {
1630              
1631             # escape - to ...
1632 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1633 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1634 0         0 $char[$i] = '...';
1635             }
1636             }
1637              
1638             # octal escape sequence
1639             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1640 0         0 $char[$i] = octchr($1);
1641             }
1642              
1643             # hexadecimal escape sequence
1644             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1645 0         0 $char[$i] = hexchr($1);
1646             }
1647              
1648             # \N{CHARNAME} --> N\{CHARNAME}
1649             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1650 0         0 $char[$i] = $1 . '\\' . $2;
1651             }
1652              
1653             # \p{PROPERTY} --> p\{PROPERTY}
1654             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1655 0         0 $char[$i] = $1 . '\\' . $2;
1656             }
1657              
1658             # \P{PROPERTY} --> P\{PROPERTY}
1659             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1660 0         0 $char[$i] = $1 . '\\' . $2;
1661             }
1662              
1663             # \p, \P, \X --> p, P, X
1664             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1665 0         0 $char[$i] = $1;
1666             }
1667              
1668             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1669 0         0 $char[$i] = CORE::chr oct $1;
1670             }
1671             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1672 0         0 $char[$i] = CORE::chr hex $1;
1673             }
1674             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1675 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1676             }
1677             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1678 0         0 $char[$i] = {
1679             '\0' => "\0",
1680             '\n' => "\n",
1681             '\r' => "\r",
1682             '\t' => "\t",
1683             '\f' => "\f",
1684             '\b' => "\x08", # \b means backspace in character class
1685             '\a' => "\a",
1686             '\e' => "\e",
1687             '\d' => '[0-9]',
1688              
1689             # Vertical tabs are now whitespace
1690             # \s in a regex now matches a vertical tab in all circumstances.
1691             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1692             # \t \n \v \f \r space
1693             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1694             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1695             '\s' => '\s',
1696              
1697             '\w' => '[0-9A-Z_a-z]',
1698             '\D' => '${Char::Elatin8::eD}',
1699             '\S' => '${Char::Elatin8::eS}',
1700             '\W' => '${Char::Elatin8::eW}',
1701              
1702             '\H' => '${Char::Elatin8::eH}',
1703             '\V' => '${Char::Elatin8::eV}',
1704             '\h' => '[\x09\x20]',
1705             '\v' => '[\x0A\x0B\x0C\x0D]',
1706             '\R' => '${Char::Elatin8::eR}',
1707              
1708             }->{$1};
1709             }
1710              
1711             # POSIX-style character classes
1712             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1713 0         0 $char[$i] = {
1714              
1715             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1716             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1717             '[:^lower:]' => '${Char::Elatin8::not_lower_i}',
1718             '[:^upper:]' => '${Char::Elatin8::not_upper_i}',
1719              
1720             }->{$1};
1721             }
1722             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1723 0         0 $char[$i] = {
1724              
1725             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1726             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1727             '[:ascii:]' => '[\x00-\x7F]',
1728             '[:blank:]' => '[\x09\x20]',
1729             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1730             '[:digit:]' => '[\x30-\x39]',
1731             '[:graph:]' => '[\x21-\x7F]',
1732             '[:lower:]' => '[\x61-\x7A]',
1733             '[:print:]' => '[\x20-\x7F]',
1734             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1735              
1736             # P.174 POSIX-Style Character Classes
1737             # in Chapter 5: Pattern Matching
1738             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1739              
1740             # P.311 11.2.4 Character Classes and other Special Escapes
1741             # in Chapter 11: perlre: Perl regular expressions
1742             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1743              
1744             # P.210 POSIX-Style Character Classes
1745             # in Chapter 5: Pattern Matching
1746             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1747              
1748             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1749              
1750             '[:upper:]' => '[\x41-\x5A]',
1751             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1752             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1753             '[:^alnum:]' => '${Char::Elatin8::not_alnum}',
1754             '[:^alpha:]' => '${Char::Elatin8::not_alpha}',
1755             '[:^ascii:]' => '${Char::Elatin8::not_ascii}',
1756             '[:^blank:]' => '${Char::Elatin8::not_blank}',
1757             '[:^cntrl:]' => '${Char::Elatin8::not_cntrl}',
1758             '[:^digit:]' => '${Char::Elatin8::not_digit}',
1759             '[:^graph:]' => '${Char::Elatin8::not_graph}',
1760             '[:^lower:]' => '${Char::Elatin8::not_lower}',
1761             '[:^print:]' => '${Char::Elatin8::not_print}',
1762             '[:^punct:]' => '${Char::Elatin8::not_punct}',
1763             '[:^space:]' => '${Char::Elatin8::not_space}',
1764             '[:^upper:]' => '${Char::Elatin8::not_upper}',
1765             '[:^word:]' => '${Char::Elatin8::not_word}',
1766             '[:^xdigit:]' => '${Char::Elatin8::not_xdigit}',
1767              
1768             }->{$1};
1769             }
1770             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1771 0         0 $char[$i] = $1;
1772             }
1773             }
1774              
1775             # open character list
1776 0         0 my @singleoctet = ();
1777 0         0 my @multipleoctet = ();
1778 0         0 for (my $i=0; $i <= $#char; ) {
1779              
1780             # escaped -
1781 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1782 0         0 $i += 1;
1783 0         0 next;
1784             }
1785              
1786             # make range regexp
1787             elsif ($char[$i] eq '...') {
1788              
1789             # range error
1790 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1791 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1792             }
1793             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1794 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1795 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]);
1796             }
1797             }
1798              
1799             # make range regexp per length
1800 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1801 0         0 my @regexp = ();
1802              
1803             # is first and last
1804 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1805 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1806             }
1807              
1808             # is first
1809             elsif ($length == CORE::length($char[$i-1])) {
1810 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1811             }
1812              
1813             # is inside in first and last
1814             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1815 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1816             }
1817              
1818             # is last
1819             elsif ($length == CORE::length($char[$i+1])) {
1820 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1821             }
1822              
1823             else {
1824 0         0 die __FILE__, ": subroutine make_regexp panic.";
1825             }
1826              
1827 0 0       0 if ($length == 1) {
1828 0         0 push @singleoctet, @regexp;
1829             }
1830             else {
1831 0         0 push @multipleoctet, @regexp;
1832             }
1833             }
1834              
1835 0         0 $i += 2;
1836             }
1837              
1838             # with /i modifier
1839             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1840 0 0       0 if ($modifier =~ /i/oxms) {
1841 0         0 my $uc = Char::Elatin8::uc($char[$i]);
1842 0         0 my $fc = Char::Elatin8::fc($char[$i]);
1843 0 0       0 if ($uc ne $fc) {
1844 0 0       0 if (CORE::length($fc) == 1) {
1845 0         0 push @singleoctet, $uc, $fc;
1846             }
1847             else {
1848 0         0 push @singleoctet, $uc;
1849 0         0 push @multipleoctet, $fc;
1850             }
1851             }
1852             else {
1853 0         0 push @singleoctet, $char[$i];
1854             }
1855             }
1856             else {
1857 0         0 push @singleoctet, $char[$i];
1858             }
1859 0         0 $i += 1;
1860             }
1861              
1862             # single character of single octet code
1863             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1864 0         0 push @singleoctet, "\t", "\x20";
1865 0         0 $i += 1;
1866             }
1867             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1868 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1869 0         0 $i += 1;
1870             }
1871             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1872 0         0 push @singleoctet, $char[$i];
1873 0         0 $i += 1;
1874             }
1875              
1876             # single character of multiple-octet code
1877             else {
1878 0         0 push @multipleoctet, $char[$i];
1879 0         0 $i += 1;
1880             }
1881             }
1882              
1883             # quote metachar
1884 0         0 for (@singleoctet) {
1885 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1886 0         0 $_ = '-';
1887             }
1888             elsif (/\A \n \z/oxms) {
1889 0         0 $_ = '\n';
1890             }
1891             elsif (/\A \r \z/oxms) {
1892 0         0 $_ = '\r';
1893             }
1894             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1895 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1896             }
1897             elsif (/\A [\x00-\xFF] \z/oxms) {
1898 0         0 $_ = quotemeta $_;
1899             }
1900             }
1901              
1902             # return character list
1903 0         0 return \@singleoctet, \@multipleoctet;
1904             }
1905              
1906             #
1907             # Latin-8 octal escape sequence
1908             #
1909             sub octchr {
1910 0     0 0 0 my($octdigit) = @_;
1911              
1912 0         0 my @binary = ();
1913 0         0 for my $octal (split(//,$octdigit)) {
1914 0         0 push @binary, {
1915             '0' => '000',
1916             '1' => '001',
1917             '2' => '010',
1918             '3' => '011',
1919             '4' => '100',
1920             '5' => '101',
1921             '6' => '110',
1922             '7' => '111',
1923             }->{$octal};
1924             }
1925 0         0 my $binary = join '', @binary;
1926              
1927 0         0 my $octchr = {
1928             # 1234567
1929             1 => pack('B*', "0000000$binary"),
1930             2 => pack('B*', "000000$binary"),
1931             3 => pack('B*', "00000$binary"),
1932             4 => pack('B*', "0000$binary"),
1933             5 => pack('B*', "000$binary"),
1934             6 => pack('B*', "00$binary"),
1935             7 => pack('B*', "0$binary"),
1936             0 => pack('B*', "$binary"),
1937              
1938             }->{CORE::length($binary) % 8};
1939              
1940 0         0 return $octchr;
1941             }
1942              
1943             #
1944             # Latin-8 hexadecimal escape sequence
1945             #
1946             sub hexchr {
1947 0     0 0 0 my($hexdigit) = @_;
1948              
1949 0         0 my $hexchr = {
1950             1 => pack('H*', "0$hexdigit"),
1951             0 => pack('H*', "$hexdigit"),
1952              
1953             }->{CORE::length($_[0]) % 2};
1954              
1955 0         0 return $hexchr;
1956             }
1957              
1958             #
1959             # Latin-8 open character list for qr
1960             #
1961             sub charlist_qr {
1962              
1963 0     0 0 0 my $modifier = pop @_;
1964 0         0 my @char = @_;
1965              
1966 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1967 0         0 my @singleoctet = @$singleoctet;
1968 0         0 my @multipleoctet = @$multipleoctet;
1969              
1970             # return character list
1971 0 0       0 if (scalar(@singleoctet) >= 1) {
1972              
1973             # with /i modifier
1974 0 0       0 if ($modifier =~ m/i/oxms) {
1975 0         0 my %singleoctet_ignorecase = ();
1976 0         0 for (@singleoctet) {
1977 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1978 0         0 for my $ord (hex($1) .. hex($2)) {
1979 0         0 my $char = CORE::chr($ord);
1980 0         0 my $uc = Char::Elatin8::uc($char);
1981 0         0 my $fc = Char::Elatin8::fc($char);
1982 0 0       0 if ($uc eq $fc) {
1983 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1984             }
1985             else {
1986 0 0       0 if (CORE::length($fc) == 1) {
1987 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1988 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1989             }
1990             else {
1991 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1992 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1993             }
1994             }
1995             }
1996             }
1997 0 0       0 if ($_ ne '') {
1998 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1999             }
2000             }
2001 0         0 my $i = 0;
2002 0         0 my @singleoctet_ignorecase = ();
2003 0         0 for my $ord (0 .. 255) {
2004 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2005 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2006             }
2007             else {
2008 0         0 $i++;
2009             }
2010             }
2011 0         0 @singleoctet = ();
2012 0         0 for my $range (@singleoctet_ignorecase) {
2013 0 0       0 if (ref $range) {
2014 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2015 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2016             }
2017             elsif (scalar(@{$range}) == 2) {
2018 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2019             }
2020             else {
2021 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2022             }
2023             }
2024             }
2025             }
2026              
2027 0         0 my $not_anchor = '';
2028              
2029 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2030             }
2031 0 0       0 if (scalar(@multipleoctet) >= 2) {
2032 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2033             }
2034             else {
2035 0         0 return $multipleoctet[0];
2036             }
2037             }
2038              
2039             #
2040             # Latin-8 open character list for not qr
2041             #
2042             sub charlist_not_qr {
2043              
2044 0     0 0 0 my $modifier = pop @_;
2045 0         0 my @char = @_;
2046              
2047 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2048 0         0 my @singleoctet = @$singleoctet;
2049 0         0 my @multipleoctet = @$multipleoctet;
2050              
2051             # with /i modifier
2052 0 0       0 if ($modifier =~ m/i/oxms) {
2053 0         0 my %singleoctet_ignorecase = ();
2054 0         0 for (@singleoctet) {
2055 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2056 0         0 for my $ord (hex($1) .. hex($2)) {
2057 0         0 my $char = CORE::chr($ord);
2058 0         0 my $uc = Char::Elatin8::uc($char);
2059 0         0 my $fc = Char::Elatin8::fc($char);
2060 0 0       0 if ($uc eq $fc) {
2061 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2062             }
2063             else {
2064 0 0       0 if (CORE::length($fc) == 1) {
2065 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2066 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2067             }
2068             else {
2069 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2070 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2071             }
2072             }
2073             }
2074             }
2075 0 0       0 if ($_ ne '') {
2076 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2077             }
2078             }
2079 0         0 my $i = 0;
2080 0         0 my @singleoctet_ignorecase = ();
2081 0         0 for my $ord (0 .. 255) {
2082 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2083 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2084             }
2085             else {
2086 0         0 $i++;
2087             }
2088             }
2089 0         0 @singleoctet = ();
2090 0         0 for my $range (@singleoctet_ignorecase) {
2091 0 0       0 if (ref $range) {
2092 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2093 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2094             }
2095             elsif (scalar(@{$range}) == 2) {
2096 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2097             }
2098             else {
2099 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2100             }
2101             }
2102             }
2103             }
2104              
2105             # return character list
2106 0 0       0 if (scalar(@multipleoctet) >= 1) {
2107 0 0       0 if (scalar(@singleoctet) >= 1) {
2108              
2109             # any character other than multiple-octet and single octet character class
2110 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2111             }
2112             else {
2113              
2114             # any character other than multiple-octet character class
2115 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2116             }
2117             }
2118             else {
2119 0 0       0 if (scalar(@singleoctet) >= 1) {
2120              
2121             # any character other than single octet character class
2122 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2123             }
2124             else {
2125              
2126             # any character
2127 0         0 return "(?:$your_char)";
2128             }
2129             }
2130             }
2131              
2132             #
2133             # open file in read mode
2134             #
2135             sub _open_r {
2136 197     197   598 my(undef,$file) = @_;
2137 197         804 $file =~ s#\A (\s) #./$1#oxms;
2138 197   33     24548 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2139             open($_[0],"< $file\0");
2140             }
2141              
2142             #
2143             # open file in write mode
2144             #
2145             sub _open_w {
2146 0     0   0 my(undef,$file) = @_;
2147 0         0 $file =~ s#\A (\s) #./$1#oxms;
2148 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2149             open($_[0],"> $file\0");
2150             }
2151              
2152             #
2153             # open file in append mode
2154             #
2155             sub _open_a {
2156 0     0   0 my(undef,$file) = @_;
2157 0         0 $file =~ s#\A (\s) #./$1#oxms;
2158 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2159             open($_[0],">> $file\0");
2160             }
2161              
2162             #
2163             # safe system
2164             #
2165             sub _systemx {
2166              
2167             # P.707 29.2.33. exec
2168             # in Chapter 29: Functions
2169             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2170             #
2171             # Be aware that in older releases of Perl, exec (and system) did not flush
2172             # your output buffer, so you needed to enable command buffering by setting $|
2173             # on one or more filehandles to avoid lost output in the case of exec, or
2174             # misordererd output in the case of system. This situation was largely remedied
2175             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2176              
2177             # P.855 exec
2178             # in Chapter 27: Functions
2179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2180             #
2181             # In very old release of Perl (before v5.6), exec (and system) did not flush
2182             # your output buffer, so you needed to enable command buffering by setting $|
2183             # on one or more filehandles to avoid lost output with exec or misordered
2184             # output with system.
2185              
2186 197     197   707 $| = 1;
2187              
2188             # P.565 23.1.2. Cleaning Up Your Environment
2189             # in Chapter 23: Security
2190             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2191              
2192             # P.656 Cleaning Up Your Environment
2193             # in Chapter 20: Security
2194             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2195              
2196             # local $ENV{'PATH'} = '.';
2197 197         1935 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2198              
2199             # P.707 29.2.33. exec
2200             # in Chapter 29: Functions
2201             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2202             #
2203             # As we mentioned earlier, exec treats a discrete list of arguments as an
2204             # indication that it should bypass shell processing. However, there is one
2205             # place where you might still get tripped up. The exec call (and system, too)
2206             # will not distinguish between a single scalar argument and an array containing
2207             # only one element.
2208             #
2209             # @args = ("echo surprise"); # just one element in list
2210             # exec @args # still subject to shell escapes
2211             # or die "exec: $!"; # because @args == 1
2212             #
2213             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2214             # first argument as the pathname, which forces the rest of the arguments to be
2215             # interpreted as a list, even if there is only one of them:
2216             #
2217             # exec { $args[0] } @args # safe even with one-argument list
2218             # or die "can't exec @args: $!";
2219              
2220             # P.855 exec
2221             # in Chapter 27: Functions
2222             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2223             #
2224             # As we mentioned earlier, exec treats a discrete list of arguments as a
2225             # directive to bypass shell processing. However, there is one place where
2226             # you might still get tripped up. The exec call (and system, too) cannot
2227             # distinguish between a single scalar argument and an array containing
2228             # only one element.
2229             #
2230             # @args = ("echo surprise"); # just one element in list
2231             # exec @args # still subject to shell escapes
2232             # || die "exec: $!"; # because @args == 1
2233             #
2234             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2235             # argument as the pathname, which forces the rest of the arguments to be
2236             # interpreted as a list, even if there is only one of them:
2237             #
2238             # exec { $args[0] } @args # safe even with one-argument list
2239             # || die "can't exec @args: $!";
2240              
2241 197         404 return CORE::system { $_[0] } @_; # safe even with one-argument list
  197         23479172  
2242             }
2243              
2244             #
2245             # Latin-8 order to character (with parameter)
2246             #
2247             sub Char::Elatin8::chr(;$) {
2248              
2249 0 0   0 0   my $c = @_ ? $_[0] : $_;
2250              
2251 0 0         if ($c == 0x00) {
2252 0           return "\x00";
2253             }
2254             else {
2255 0           my @chr = ();
2256 0           while ($c > 0) {
2257 0           unshift @chr, ($c % 0x100);
2258 0           $c = int($c / 0x100);
2259             }
2260 0           return pack 'C*', @chr;
2261             }
2262             }
2263              
2264             #
2265             # Latin-8 order to character (without parameter)
2266             #
2267             sub Char::Elatin8::chr_() {
2268              
2269 0     0 0   my $c = $_;
2270              
2271 0 0         if ($c == 0x00) {
2272 0           return "\x00";
2273             }
2274             else {
2275 0           my @chr = ();
2276 0           while ($c > 0) {
2277 0           unshift @chr, ($c % 0x100);
2278 0           $c = int($c / 0x100);
2279             }
2280 0           return pack 'C*', @chr;
2281             }
2282             }
2283              
2284             #
2285             # Latin-8 path globbing (with parameter)
2286             #
2287             sub Char::Elatin8::glob($) {
2288              
2289 0 0   0 0   if (wantarray) {
2290 0           my @glob = _DOS_like_glob(@_);
2291 0           for my $glob (@glob) {
2292 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2293             }
2294 0           return @glob;
2295             }
2296             else {
2297 0           my $glob = _DOS_like_glob(@_);
2298 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2299 0           return $glob;
2300             }
2301             }
2302              
2303             #
2304             # Latin-8 path globbing (without parameter)
2305             #
2306             sub Char::Elatin8::glob_() {
2307              
2308 0 0   0 0   if (wantarray) {
2309 0           my @glob = _DOS_like_glob();
2310 0           for my $glob (@glob) {
2311 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2312             }
2313 0           return @glob;
2314             }
2315             else {
2316 0           my $glob = _DOS_like_glob();
2317 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2318 0           return $glob;
2319             }
2320             }
2321              
2322             #
2323             # Latin-8 path globbing via File::DosGlob 1.10
2324             #
2325             # Often I confuse "_dosglob" and "_doglob".
2326             # So, I renamed "_dosglob" to "_DOS_like_glob".
2327             #
2328             my %iter;
2329             my %entries;
2330             sub _DOS_like_glob {
2331              
2332             # context (keyed by second cxix argument provided by core)
2333 0     0     my($expr,$cxix) = @_;
2334              
2335             # glob without args defaults to $_
2336 0 0         $expr = $_ if not defined $expr;
2337              
2338             # represents the current user's home directory
2339             #
2340             # 7.3. Expanding Tildes in Filenames
2341             # in Chapter 7. File Access
2342             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2343             #
2344             # and File::HomeDir, File::HomeDir::Windows module
2345              
2346             # DOS-like system
2347 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2348 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2349 0           { my_home_MSWin32() }oxmse;
2350             }
2351              
2352             # UNIX-like system
2353             else {
2354 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2355 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2356             }
2357              
2358             # assume global context if not provided one
2359 0 0         $cxix = '_G_' if not defined $cxix;
2360 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2361              
2362             # if we're just beginning, do it all first
2363 0 0         if ($iter{$cxix} == 0) {
2364 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2365             }
2366              
2367             # chuck it all out, quick or slow
2368 0 0         if (wantarray) {
2369 0           delete $iter{$cxix};
2370 0           return @{delete $entries{$cxix}};
  0            
2371             }
2372             else {
2373 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2374 0           return shift @{$entries{$cxix}};
  0            
2375             }
2376             else {
2377             # return undef for EOL
2378 0           delete $iter{$cxix};
2379 0           delete $entries{$cxix};
2380 0           return undef;
2381             }
2382             }
2383             }
2384              
2385             #
2386             # Latin-8 path globbing subroutine
2387             #
2388             sub _do_glob {
2389              
2390 0     0     my($cond,@expr) = @_;
2391 0           my @glob = ();
2392 0           my $fix_drive_relative_paths = 0;
2393              
2394             OUTER:
2395 0           for my $expr (@expr) {
2396 0 0         next OUTER if not defined $expr;
2397 0 0         next OUTER if $expr eq '';
2398              
2399 0           my @matched = ();
2400 0           my @globdir = ();
2401 0           my $head = '.';
2402 0           my $pathsep = '/';
2403 0           my $tail;
2404              
2405             # if argument is within quotes strip em and do no globbing
2406 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2407 0           $expr = $1;
2408 0 0         if ($cond eq 'd') {
2409 0 0         if (-d $expr) {
2410 0           push @glob, $expr;
2411             }
2412             }
2413             else {
2414 0 0         if (-e $expr) {
2415 0           push @glob, $expr;
2416             }
2417             }
2418 0           next OUTER;
2419             }
2420              
2421             # wildcards with a drive prefix such as h:*.pm must be changed
2422             # to h:./*.pm to expand correctly
2423 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2424 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2425 0           $fix_drive_relative_paths = 1;
2426             }
2427             }
2428              
2429 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2430 0 0         if ($tail eq '') {
2431 0           push @glob, $expr;
2432 0           next OUTER;
2433             }
2434 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2435 0 0         if (@globdir = _do_glob('d', $head)) {
2436 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2437 0           next OUTER;
2438             }
2439             }
2440 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2441 0           $head .= $pathsep;
2442             }
2443 0           $expr = $tail;
2444             }
2445              
2446             # If file component has no wildcards, we can avoid opendir
2447 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2448 0 0         if ($head eq '.') {
2449 0           $head = '';
2450             }
2451 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2452 0           $head .= $pathsep;
2453             }
2454 0           $head .= $expr;
2455 0 0         if ($cond eq 'd') {
2456 0 0         if (-d $head) {
2457 0           push @glob, $head;
2458             }
2459             }
2460             else {
2461 0 0         if (-e $head) {
2462 0           push @glob, $head;
2463             }
2464             }
2465 0           next OUTER;
2466             }
2467 0 0         opendir(*DIR, $head) or next OUTER;
2468 0           my @leaf = readdir DIR;
2469 0           closedir DIR;
2470              
2471 0 0         if ($head eq '.') {
2472 0           $head = '';
2473             }
2474 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2475 0           $head .= $pathsep;
2476             }
2477              
2478 0           my $pattern = '';
2479 0           while ($expr =~ / \G ($q_char) /oxgc) {
2480 0           my $char = $1;
2481              
2482             # 6.9. Matching Shell Globs as Regular Expressions
2483             # in Chapter 6. Pattern Matching
2484             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2485             # (and so on)
2486              
2487 0 0         if ($char eq '*') {
    0          
    0          
2488 0           $pattern .= "(?:$your_char)*",
2489             }
2490             elsif ($char eq '?') {
2491 0           $pattern .= "(?:$your_char)?", # DOS style
2492             # $pattern .= "(?:$your_char)", # UNIX style
2493             }
2494             elsif ((my $fc = Char::Elatin8::fc($char)) ne $char) {
2495 0           $pattern .= $fc;
2496             }
2497             else {
2498 0           $pattern .= quotemeta $char;
2499             }
2500             }
2501 0     0     my $matchsub = sub { Char::Elatin8::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2502              
2503             # if ($@) {
2504             # print STDERR "$0: $@\n";
2505             # next OUTER;
2506             # }
2507              
2508             INNER:
2509 0           for my $leaf (@leaf) {
2510 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2511 0           next INNER;
2512             }
2513 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2514 0           next INNER;
2515             }
2516              
2517 0 0         if (&$matchsub($leaf)) {
2518 0           push @matched, "$head$leaf";
2519 0           next INNER;
2520             }
2521              
2522             # [DOS compatibility special case]
2523             # Failed, add a trailing dot and try again, but only...
2524              
2525 0 0 0       if (Char::Elatin8::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2526             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2527             Char::Elatin8::index($pattern,'\\.') != -1 # pattern has a dot.
2528             ) {
2529 0 0         if (&$matchsub("$leaf.")) {
2530 0           push @matched, "$head$leaf";
2531 0           next INNER;
2532             }
2533             }
2534             }
2535 0 0         if (@matched) {
2536 0           push @glob, @matched;
2537             }
2538             }
2539 0 0         if ($fix_drive_relative_paths) {
2540 0           for my $glob (@glob) {
2541 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2542             }
2543             }
2544 0           return @glob;
2545             }
2546              
2547             #
2548             # Latin-8 parse line
2549             #
2550             sub _parse_line {
2551              
2552 0     0     my($line) = @_;
2553              
2554 0           $line .= ' ';
2555 0           my @piece = ();
2556 0           while ($line =~ /
2557             " ( (?: [^"] )* ) " \s+ |
2558             ( (?: [^"\s] )* ) \s+
2559             /oxmsg
2560             ) {
2561 0 0         push @piece, defined($1) ? $1 : $2;
2562             }
2563 0           return @piece;
2564             }
2565              
2566             #
2567             # Latin-8 parse path
2568             #
2569             sub _parse_path {
2570              
2571 0     0     my($path,$pathsep) = @_;
2572              
2573 0           $path .= '/';
2574 0           my @subpath = ();
2575 0           while ($path =~ /
2576             ((?: [^\/\\] )+?) [\/\\]
2577             /oxmsg
2578             ) {
2579 0           push @subpath, $1;
2580             }
2581              
2582 0           my $tail = pop @subpath;
2583 0           my $head = join $pathsep, @subpath;
2584 0           return $head, $tail;
2585             }
2586              
2587             #
2588             # via File::HomeDir::Windows 1.00
2589             #
2590             sub my_home_MSWin32 {
2591              
2592             # A lot of unix people and unix-derived tools rely on
2593             # the ability to overload HOME. We will support it too
2594             # so that they can replace raw HOME calls with File::HomeDir.
2595 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2596 0           return $ENV{'HOME'};
2597             }
2598              
2599             # Do we have a user profile?
2600             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2601 0           return $ENV{'USERPROFILE'};
2602             }
2603              
2604             # Some Windows use something like $ENV{'HOME'}
2605             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2606 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2607             }
2608              
2609 0           return undef;
2610             }
2611              
2612             #
2613             # via File::HomeDir::Unix 1.00
2614             #
2615             sub my_home {
2616 0     0 0   my $home;
2617              
2618 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2619 0           $home = $ENV{'HOME'};
2620             }
2621              
2622             # This is from the original code, but I'm guessing
2623             # it means "login directory" and exists on some Unixes.
2624             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2625 0           $home = $ENV{'LOGDIR'};
2626             }
2627              
2628             ### More-desperate methods
2629              
2630             # Light desperation on any (Unixish) platform
2631             else {
2632 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2633             }
2634              
2635             # On Unix in general, a non-existant home means "no home"
2636             # For example, "nobody"-like users might use /nonexistant
2637 0 0 0       if (defined $home and ! -d($home)) {
2638 0           $home = undef;
2639             }
2640 0           return $home;
2641             }
2642              
2643             #
2644             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2645             #
2646             sub Char::Elatin8::PREMATCH {
2647 0     0 0   return $`;
2648             }
2649              
2650             #
2651             # ${^MATCH}, $MATCH, $& the string that matched
2652             #
2653             sub Char::Elatin8::MATCH {
2654 0     0 0   return $&;
2655             }
2656              
2657             #
2658             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2659             #
2660             sub Char::Elatin8::POSTMATCH {
2661 0     0 0   return $';
2662             }
2663              
2664             #
2665             # Latin-8 character to order (with parameter)
2666             #
2667             sub Char::Latin8::ord(;$) {
2668              
2669 0 0   0 1   local $_ = shift if @_;
2670              
2671 0 0         if (/\A ($q_char) /oxms) {
2672 0           my @ord = unpack 'C*', $1;
2673 0           my $ord = 0;
2674 0           while (my $o = shift @ord) {
2675 0           $ord = $ord * 0x100 + $o;
2676             }
2677 0           return $ord;
2678             }
2679             else {
2680 0           return CORE::ord $_;
2681             }
2682             }
2683              
2684             #
2685             # Latin-8 character to order (without parameter)
2686             #
2687             sub Char::Latin8::ord_() {
2688              
2689 0 0   0 0   if (/\A ($q_char) /oxms) {
2690 0           my @ord = unpack 'C*', $1;
2691 0           my $ord = 0;
2692 0           while (my $o = shift @ord) {
2693 0           $ord = $ord * 0x100 + $o;
2694             }
2695 0           return $ord;
2696             }
2697             else {
2698 0           return CORE::ord $_;
2699             }
2700             }
2701              
2702             #
2703             # Latin-8 reverse
2704             #
2705             sub Char::Latin8::reverse(@) {
2706              
2707 0 0   0 0   if (wantarray) {
2708 0           return CORE::reverse @_;
2709             }
2710             else {
2711              
2712             # One of us once cornered Larry in an elevator and asked him what
2713             # problem he was solving with this, but he looked as far off into
2714             # the distance as he could in an elevator and said, "It seemed like
2715             # a good idea at the time."
2716              
2717 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2718             }
2719             }
2720              
2721             #
2722             # Latin-8 getc (with parameter, without parameter)
2723             #
2724             sub Char::Latin8::getc(;*@) {
2725              
2726 0     0 0   my($package) = caller;
2727 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2728 0 0 0       croak 'Too many arguments for Char::Latin8::getc' if @_ and not wantarray;
2729              
2730 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2731 0           my $getc = '';
2732 0           for my $length ($length[0] .. $length[-1]) {
2733 0           $getc .= CORE::getc($fh);
2734 0 0         if (exists $range_tr{CORE::length($getc)}) {
2735 0 0         if ($getc =~ /\A ${Char::Elatin8::dot_s} \z/oxms) {
2736 0 0         return wantarray ? ($getc,@_) : $getc;
2737             }
2738             }
2739             }
2740 0 0         return wantarray ? ($getc,@_) : $getc;
2741             }
2742              
2743             #
2744             # Latin-8 length by character
2745             #
2746             sub Char::Latin8::length(;$) {
2747              
2748 0 0   0 1   local $_ = shift if @_;
2749              
2750 0           local @_ = /\G ($q_char) /oxmsg;
2751 0           return scalar @_;
2752             }
2753              
2754             #
2755             # Latin-8 substr by character
2756             #
2757             BEGIN {
2758              
2759             # P.232 The lvalue Attribute
2760             # in Chapter 6: Subroutines
2761             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2762              
2763             # P.336 The lvalue Attribute
2764             # in Chapter 7: Subroutines
2765             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2766              
2767             # P.144 8.4 Lvalue subroutines
2768             # in Chapter 8: perlsub: Perl subroutines
2769             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2770              
2771 197 50 0 197 1 154166 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            
2772             # vv----------------*******
2773             sub Char::Latin8::substr($$;$$) %s {
2774              
2775             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2776              
2777             # If the substring is beyond either end of the string, substr() returns the undefined
2778             # value and produces a warning. When used as an lvalue, specifying a substring that
2779             # is entirely outside the string raises an exception.
2780             # http://perldoc.perl.org/functions/substr.html
2781              
2782             # A return with no argument returns the scalar value undef in scalar context,
2783             # an empty list () in list context, and (naturally) nothing at all in void
2784             # context.
2785              
2786             my $offset = $_[1];
2787             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2788             return;
2789             }
2790              
2791             # substr($string,$offset,$length,$replacement)
2792             if (@_ == 4) {
2793             my(undef,undef,$length,$replacement) = @_;
2794             my $substr = join '', splice(@char, $offset, $length, $replacement);
2795             $_[0] = join '', @char;
2796              
2797             # return $substr; this doesn't work, don't say "return"
2798             $substr;
2799             }
2800              
2801             # substr($string,$offset,$length)
2802             elsif (@_ == 3) {
2803             my(undef,undef,$length) = @_;
2804             my $octet_offset = 0;
2805             my $octet_length = 0;
2806             if ($offset == 0) {
2807             $octet_offset = 0;
2808             }
2809             elsif ($offset > 0) {
2810             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2811             }
2812             else {
2813             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2814             }
2815             if ($length == 0) {
2816             $octet_length = 0;
2817             }
2818             elsif ($length > 0) {
2819             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2820             }
2821             else {
2822             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2823             }
2824             CORE::substr($_[0], $octet_offset, $octet_length);
2825             }
2826              
2827             # substr($string,$offset)
2828             else {
2829             my $octet_offset = 0;
2830             if ($offset == 0) {
2831             $octet_offset = 0;
2832             }
2833             elsif ($offset > 0) {
2834             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2835             }
2836             else {
2837             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2838             }
2839             CORE::substr($_[0], $octet_offset);
2840             }
2841             }
2842             END
2843             }
2844              
2845             #
2846             # Latin-8 index by character
2847             #
2848             sub Char::Latin8::index($$;$) {
2849              
2850 0     0 1   my $index;
2851 0 0         if (@_ == 3) {
2852 0           $index = Char::Elatin8::index($_[0], $_[1], CORE::length(Char::Latin8::substr($_[0], 0, $_[2])));
2853             }
2854             else {
2855 0           $index = Char::Elatin8::index($_[0], $_[1]);
2856             }
2857              
2858 0 0         if ($index == -1) {
2859 0           return -1;
2860             }
2861             else {
2862 0           return Char::Latin8::length(CORE::substr $_[0], 0, $index);
2863             }
2864             }
2865              
2866             #
2867             # Latin-8 rindex by character
2868             #
2869             sub Char::Latin8::rindex($$;$) {
2870              
2871 0     0 1   my $rindex;
2872 0 0         if (@_ == 3) {
2873 0           $rindex = Char::Elatin8::rindex($_[0], $_[1], CORE::length(Char::Latin8::substr($_[0], 0, $_[2])));
2874             }
2875             else {
2876 0           $rindex = Char::Elatin8::rindex($_[0], $_[1]);
2877             }
2878              
2879 0 0         if ($rindex == -1) {
2880 0           return -1;
2881             }
2882             else {
2883 0           return Char::Latin8::length(CORE::substr $_[0], 0, $rindex);
2884             }
2885             }
2886              
2887             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2888             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2889 197     197   17238 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  197     197   2107  
  197         432  
  197         16301  
2890              
2891             # ord() to ord() or Char::Latin8::ord()
2892 197     197   11961 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  197     197   1195  
  197         409  
  197         13497  
2893              
2894             # ord to ord or Char::Latin8::ord_
2895 197     197   12075 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  197     197   1497  
  197         391  
  197         12307  
2896              
2897             # reverse to reverse or Char::Latin8::reverse
2898 197     197   12603 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  197     197   1112  
  197         415  
  197         13369  
2899              
2900             # getc to getc or Char::Latin8::getc
2901 197     197   11615 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  197     197   1258  
  197         396  
  197         14268  
2902              
2903             # P.1023 Appendix W.9 Multibyte Anchoring
2904             # of ISBN 1-56592-224-7 CJKV Information Processing
2905              
2906             my $anchor = '';
2907              
2908 197     197   12419 BEGIN { CORE::eval q{ use vars qw($nest) } }
  197     197   1145  
  197         360  
  197         12169553  
2909              
2910             # regexp of nested parens in qqXX
2911              
2912             # P.340 Matching Nested Constructs with Embedded Code
2913             # in Chapter 7: Perl
2914             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2915              
2916             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2917             \\c[\x40-\x5F] |
2918             \\ [\x00-\xFF] |
2919             [^()] |
2920             \( (?{$nest++}) |
2921             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2922             }xms;
2923             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2924             \\c[\x40-\x5F] |
2925             \\ [\x00-\xFF] |
2926             [^{}] |
2927             \{ (?{$nest++}) |
2928             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2929             }xms;
2930             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2931             \\c[\x40-\x5F] |
2932             \\ [\x00-\xFF] |
2933             [^[\]] |
2934             \[ (?{$nest++}) |
2935             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2936             }xms;
2937             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2938             \\c[\x40-\x5F] |
2939             \\ [\x00-\xFF] |
2940             [^<>] |
2941             \< (?{$nest++}) |
2942             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2943             }xms;
2944             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2945             (?: ::)? (?:
2946             [a-zA-Z_][a-zA-Z_0-9]*
2947             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2948             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2949             ))
2950             }xms;
2951             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2952             (?: ::)? (?:
2953             [0-9]+ |
2954             [^a-zA-Z_0-9\[\]] |
2955             ^[A-Z] |
2956             [a-zA-Z_][a-zA-Z_0-9]*
2957             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2958             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2959             ))
2960             }xms;
2961             my $qq_substr = qr{(?: Char::Latin8::substr | CORE::substr | substr ) \( $qq_paren \)
2962             }xms;
2963              
2964             # regexp of nested parens in qXX
2965             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2966             [^()] |
2967             \( (?{$nest++}) |
2968             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2969             }xms;
2970             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2971             [^{}] |
2972             \{ (?{$nest++}) |
2973             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2974             }xms;
2975             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2976             [^[\]] |
2977             \[ (?{$nest++}) |
2978             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2979             }xms;
2980             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2981             [^<>] |
2982             \< (?{$nest++}) |
2983             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2984             }xms;
2985              
2986             my $matched = '';
2987             my $s_matched = '';
2988              
2989             my $tr_variable = ''; # variable of tr///
2990             my $sub_variable = ''; # variable of s///
2991             my $bind_operator = ''; # =~ or !~
2992              
2993             my @heredoc = (); # here document
2994             my @heredoc_delimiter = ();
2995             my $here_script = ''; # here script
2996              
2997             #
2998             # escape Latin-8 script
2999             #
3000             sub Char::Latin8::escape(;$) {
3001 0 0   0 0   local($_) = $_[0] if @_;
3002              
3003             # P.359 The Study Function
3004             # in Chapter 7: Perl
3005             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3006              
3007 0           study $_; # Yes, I studied study yesterday.
3008              
3009             # while all script
3010              
3011             # 6.14. Matching from Where the Last Pattern Left Off
3012             # in Chapter 6. Pattern Matching
3013             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3014             # (and so on)
3015              
3016             # one member of Tag-team
3017             #
3018             # P.128 Start of match (or end of previous match): \G
3019             # P.130 Advanced Use of \G with Perl
3020             # in Chapter 3: Overview of Regular Expression Features and Flavors
3021             # P.255 Use leading anchors
3022             # P.256 Expose ^ and \G at the front expressions
3023             # in Chapter 6: Crafting an Efficient Expression
3024             # P.315 "Tag-team" matching with /gc
3025             # in Chapter 7: Perl
3026             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3027              
3028 0           my $e_script = '';
3029 0           while (not /\G \z/oxgc) { # member
3030 0           $e_script .= Char::Latin8::escape_token();
3031             }
3032              
3033 0           return $e_script;
3034             }
3035              
3036             #
3037             # escape Latin-8 token of script
3038             #
3039             sub Char::Latin8::escape_token {
3040              
3041             # \n output here document
3042              
3043 0     0 0   my $ignore_modules = join('|', qw(
3044             utf8
3045             bytes
3046             charnames
3047             I18N::Japanese
3048             I18N::Collate
3049             I18N::JExt
3050             File::DosGlob
3051             Wild
3052             Wildcard
3053             Japanese
3054             ));
3055              
3056             # another member of Tag-team
3057             #
3058             # P.315 "Tag-team" matching with /gc
3059             # in Chapter 7: Perl
3060             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3061              
3062 0 0 0       if (/\G ( \n ) /oxgc) { # another member (and so on)
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3063 0           my $heredoc = '';
3064 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3065 0           $slash = 'm//';
3066              
3067 0           $heredoc = join '', @heredoc;
3068 0           @heredoc = ();
3069              
3070             # skip here document
3071 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3072 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3073             }
3074 0           @heredoc_delimiter = ();
3075              
3076 0           $here_script = '';
3077             }
3078 0           return "\n" . $heredoc;
3079             }
3080              
3081             # ignore space, comment
3082 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
3083              
3084             # if (, elsif (, unless (, while (, until (, given (, and when (
3085              
3086             # given, when
3087              
3088             # P.225 The given Statement
3089             # in Chapter 15: Smart Matching and given-when
3090             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3091              
3092             # P.133 The given Statement
3093             # in Chapter 4: Statements and Declarations
3094             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3095              
3096             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
3097 0           $slash = 'm//';
3098 0           return $1;
3099             }
3100              
3101             # scalar variable ($scalar = ...) =~ tr///;
3102             # scalar variable ($scalar = ...) =~ s///;
3103              
3104             # state
3105              
3106             # P.68 Persistent, Private Variables
3107             # in Chapter 4: Subroutines
3108             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3109              
3110             # P.160 Persistent Lexically Scoped Variables: state
3111             # in Chapter 4: Statements and Declarations
3112             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3113              
3114             # (and so on)
3115              
3116             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
3117 0           my $e_string = e_string($1);
3118              
3119 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3120 0           $tr_variable = $e_string . e_string($1);
3121 0           $bind_operator = $2;
3122 0           $slash = 'm//';
3123 0           return '';
3124             }
3125             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3126 0           $sub_variable = $e_string . e_string($1);
3127 0           $bind_operator = $2;
3128 0           $slash = 'm//';
3129 0           return '';
3130             }
3131             else {
3132 0           $slash = 'div';
3133 0           return $e_string;
3134             }
3135             }
3136              
3137             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin8::PREMATCH()
3138             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
3139 0           $slash = 'div';
3140 0           return q{Char::Elatin8::PREMATCH()};
3141             }
3142              
3143             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin8::MATCH()
3144             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
3145 0           $slash = 'div';
3146 0           return q{Char::Elatin8::MATCH()};
3147             }
3148              
3149             # $', ${'} --> $', ${'}
3150             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3151 0           $slash = 'div';
3152 0           return $1;
3153             }
3154              
3155             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin8::POSTMATCH()
3156             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
3157 0           $slash = 'div';
3158 0           return q{Char::Elatin8::POSTMATCH()};
3159             }
3160              
3161             # scalar variable $scalar =~ tr///;
3162             # scalar variable $scalar =~ s///;
3163             # substr() =~ tr///;
3164             # substr() =~ s///;
3165             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3166 0           my $scalar = e_string($1);
3167              
3168 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3169 0           $tr_variable = $scalar;
3170 0           $bind_operator = $1;
3171 0           $slash = 'm//';
3172 0           return '';
3173             }
3174             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3175 0           $sub_variable = $scalar;
3176 0           $bind_operator = $1;
3177 0           $slash = 'm//';
3178 0           return '';
3179             }
3180             else {
3181 0           $slash = 'div';
3182 0           return $scalar;
3183             }
3184             }
3185              
3186             # end of statement
3187             elsif (/\G ( [,;] ) /oxgc) {
3188 0           $slash = 'm//';
3189              
3190             # clear tr/// variable
3191 0           $tr_variable = '';
3192              
3193             # clear s/// variable
3194 0           $sub_variable = '';
3195              
3196 0           $bind_operator = '';
3197              
3198 0           return $1;
3199             }
3200              
3201             # bareword
3202             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
3203 0           return $1;
3204             }
3205              
3206             # $0 --> $0
3207             elsif (/\G ( \$ 0 ) /oxmsgc) {
3208 0           $slash = 'div';
3209 0           return $1;
3210             }
3211             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
3212 0           $slash = 'div';
3213 0           return $1;
3214             }
3215              
3216             # $$ --> $$
3217             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3218 0           $slash = 'div';
3219 0           return $1;
3220             }
3221              
3222             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3223             # $1, $2, $3 --> $1, $2, $3 otherwise
3224             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
3225 0           $slash = 'div';
3226 0           return e_capture($1);
3227             }
3228             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
3229 0           $slash = 'div';
3230 0           return e_capture($1);
3231             }
3232              
3233             # $$foo[ ... ] --> $ $foo->[ ... ]
3234             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
3235 0           $slash = 'div';
3236 0           return e_capture($1.'->'.$2);
3237             }
3238              
3239             # $$foo{ ... } --> $ $foo->{ ... }
3240             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
3241 0           $slash = 'div';
3242 0           return e_capture($1.'->'.$2);
3243             }
3244              
3245             # $$foo
3246             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
3247 0           $slash = 'div';
3248 0           return e_capture($1);
3249             }
3250              
3251             # ${ foo }
3252             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
3253 0           $slash = 'div';
3254 0           return '${' . $1 . '}';
3255             }
3256              
3257             # ${ ... }
3258             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
3259 0           $slash = 'div';
3260 0           return e_capture($1);
3261             }
3262              
3263             # variable or function
3264             # $ @ % & * $ #
3265             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) {
3266 0           $slash = 'div';
3267 0           return $1;
3268             }
3269             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3270             # $ @ # \ ' " / ? ( ) [ ] < >
3271             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3272 0           $slash = 'div';
3273 0           return $1;
3274             }
3275              
3276             # while ()
3277             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
3278 0           return $1;
3279             }
3280              
3281             # while () --- glob
3282              
3283             # avoid "Error: Runtime exception" of perl version 5.005_03
3284              
3285             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
3286 0           return 'while ($_ = Char::Elatin8::glob("' . $1 . '"))';
3287             }
3288              
3289             # while (glob)
3290             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
3291 0           return 'while ($_ = Char::Elatin8::glob_)';
3292             }
3293              
3294             # while (glob(WILDCARD))
3295             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
3296 0           return 'while ($_ = Char::Elatin8::glob';
3297             }
3298              
3299             # doit if, doit unless, doit while, doit until, doit for, doit when
3300 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3301              
3302             # subroutines of package Char::Elatin8
3303 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3304 0           elsif (/\G \b Char::Latin8::eval (?= \s* \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3305 0           elsif (/\G \b Char::Latin8::eval \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'eval Char::Latin8::escape'; }
  0            
3306 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3307 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::chop'; }
  0            
3308 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3309 0           elsif (/\G \b Char::Latin8::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin8::index'; }
  0            
3310 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::index'; }
  0            
3311 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3312 0           elsif (/\G \b Char::Latin8::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin8::rindex'; }
  0            
3313 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::rindex'; }
  0            
3314 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::lc'; }
  0            
3315 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::lcfirst'; }
  0            
3316 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::uc'; }
  0            
3317 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::ucfirst'; }
  0            
3318 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::fc'; }
  0            
3319              
3320             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3321 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3322 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3323 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3324 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3325 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3326 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3327 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3328              
3329 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3330 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3331 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3332 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3333 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3334 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3335 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3336              
3337             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3338 0           { $slash = 'm//'; return "-s $1"; }
  0            
3339 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3340 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3341 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3342              
3343 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3344 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3345 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::chr'; }
  0            
3346 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3347 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3348 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::glob'; }
  0            
3349 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::lc_'; }
  0            
3350 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::lcfirst_'; }
  0            
3351 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::uc_'; }
  0            
3352 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::ucfirst_'; }
  0            
3353 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::fc_'; }
  0            
3354 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3355              
3356 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3357 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3358 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::chr_'; }
  0            
3359 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3360 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3361 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin8::glob_'; }
  0            
3362 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3363 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3364             # split
3365             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
3366 0           $slash = 'm//';
3367              
3368 0           my $e = '';
3369 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
3370 0           $e .= $1;
3371             }
3372              
3373             # end of split
3374 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::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          
3375              
3376             # split scalar value
3377 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Elatin8::split' . $e . e_string($1); }
3378              
3379             # split literal space
3380 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Elatin8::split' . $e . qq {qq$1 $2}; }
3381 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; }
3382 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; }
3383 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; }
3384 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; }
3385 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; }
3386 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Elatin8::split' . $e . qq {q$1 $2}; }
3387 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; }
3388 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; }
3389 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; }
3390 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; }
3391 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; }
3392 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Elatin8::split' . $e . qq {' '}; }
3393 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Elatin8::split' . $e . qq {" "}; }
3394              
3395             # split qq//
3396             elsif (/\G \b (qq) \b /oxgc) {
3397 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3398             else {
3399 0           while (not /\G \z/oxgc) {
3400 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3401 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3402 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3403 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3404 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3405 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3406 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3407             }
3408 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3409             }
3410             }
3411              
3412             # split qr//
3413             elsif (/\G \b (qr) \b /oxgc) {
3414 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3415             else {
3416 0           while (not /\G \z/oxgc) {
3417 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3418 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3419 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3420 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3421 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3422 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3423 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3424 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3425             }
3426 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3427             }
3428             }
3429              
3430             # split q//
3431             elsif (/\G \b (q) \b /oxgc) {
3432 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3433             else {
3434 0           while (not /\G \z/oxgc) {
3435 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3436 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3437 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3438 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3439 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3440 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3441 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3442             }
3443 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3444             }
3445             }
3446              
3447             # split m//
3448             elsif (/\G \b (m) \b /oxgc) {
3449 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3450             else {
3451 0           while (not /\G \z/oxgc) {
3452 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3453 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3454 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3455 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3456 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3457 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3458 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3459 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3460             }
3461 0           die __FILE__, ": Search pattern not terminated";
3462             }
3463             }
3464              
3465             # split ''
3466             elsif (/\G (\') /oxgc) {
3467 0           my $q_string = '';
3468 0           while (not /\G \z/oxgc) {
3469 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3470 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3471 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3472 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3473             }
3474 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3475             }
3476              
3477             # split ""
3478             elsif (/\G (\") /oxgc) {
3479 0           my $qq_string = '';
3480 0           while (not /\G \z/oxgc) {
3481 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3482 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3483 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3484 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3485             }
3486 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3487             }
3488              
3489             # split //
3490             elsif (/\G (\/) /oxgc) {
3491 0           my $regexp = '';
3492 0           while (not /\G \z/oxgc) {
3493 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3494 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3495 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3496 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3497             }
3498 0           die __FILE__, ": Search pattern not terminated";
3499             }
3500             }
3501              
3502             # tr/// or y///
3503              
3504             # about [cdsrbB]* (/B modifier)
3505             #
3506             # P.559 appendix C
3507             # of ISBN 4-89052-384-7 Programming perl
3508             # (Japanese title is: Perl puroguramingu)
3509              
3510             elsif (/\G \b ( tr | y ) \b /oxgc) {
3511 0           my $ope = $1;
3512              
3513             # $1 $2 $3 $4 $5 $6
3514 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3515 0           my @tr = ($tr_variable,$2);
3516 0           return e_tr(@tr,'',$4,$6);
3517             }
3518             else {
3519 0           my $e = '';
3520 0           while (not /\G \z/oxgc) {
3521 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3522             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3523 0           my @tr = ($tr_variable,$2);
3524 0           while (not /\G \z/oxgc) {
3525 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3526 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3527 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3528 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3529 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3530 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3531             }
3532 0           die __FILE__, ": Transliteration replacement not terminated";
3533             }
3534             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3535 0           my @tr = ($tr_variable,$2);
3536 0           while (not /\G \z/oxgc) {
3537 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3538 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3539 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3540 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3541 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3542 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3543             }
3544 0           die __FILE__, ": Transliteration replacement not terminated";
3545             }
3546             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3547 0           my @tr = ($tr_variable,$2);
3548 0           while (not /\G \z/oxgc) {
3549 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3550 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3551 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3552 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3553 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3554 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3555             }
3556 0           die __FILE__, ": Transliteration replacement not terminated";
3557             }
3558             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3559 0           my @tr = ($tr_variable,$2);
3560 0           while (not /\G \z/oxgc) {
3561 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3562 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3563 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3564 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3565 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3566 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3567             }
3568 0           die __FILE__, ": Transliteration replacement not terminated";
3569             }
3570             # $1 $2 $3 $4 $5 $6
3571             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3572 0           my @tr = ($tr_variable,$2);
3573 0           return e_tr(@tr,'',$4,$6);
3574             }
3575             }
3576 0           die __FILE__, ": Transliteration pattern not terminated";
3577             }
3578             }
3579              
3580             # qq//
3581             elsif (/\G \b (qq) \b /oxgc) {
3582 0           my $ope = $1;
3583              
3584             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3585 0 0         if (/\G (\#) /oxgc) { # qq# #
3586 0           my $qq_string = '';
3587 0           while (not /\G \z/oxgc) {
3588 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3589 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3590 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3591 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3592             }
3593 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3594             }
3595              
3596             else {
3597 0           my $e = '';
3598 0           while (not /\G \z/oxgc) {
3599 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3600              
3601             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3602             elsif (/\G (\() /oxgc) { # qq ( )
3603 0           my $qq_string = '';
3604 0           local $nest = 1;
3605 0           while (not /\G \z/oxgc) {
3606 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3607 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3608 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3609             elsif (/\G (\)) /oxgc) {
3610 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3611 0           else { $qq_string .= $1; }
3612             }
3613 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3614             }
3615 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3616             }
3617              
3618             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3619             elsif (/\G (\{) /oxgc) { # qq { }
3620 0           my $qq_string = '';
3621 0           local $nest = 1;
3622 0           while (not /\G \z/oxgc) {
3623 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3624 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3625 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3626             elsif (/\G (\}) /oxgc) {
3627 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3628 0           else { $qq_string .= $1; }
3629             }
3630 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3631             }
3632 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3633             }
3634              
3635             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3636             elsif (/\G (\[) /oxgc) { # qq [ ]
3637 0           my $qq_string = '';
3638 0           local $nest = 1;
3639 0           while (not /\G \z/oxgc) {
3640 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3641 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3642 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3643             elsif (/\G (\]) /oxgc) {
3644 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3645 0           else { $qq_string .= $1; }
3646             }
3647 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3648             }
3649 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3650             }
3651              
3652             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3653             elsif (/\G (\<) /oxgc) { # qq < >
3654 0           my $qq_string = '';
3655 0           local $nest = 1;
3656 0           while (not /\G \z/oxgc) {
3657 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3658 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3659 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3660             elsif (/\G (\>) /oxgc) {
3661 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3662 0           else { $qq_string .= $1; }
3663             }
3664 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3665             }
3666 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3667             }
3668              
3669             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3670             elsif (/\G (\S) /oxgc) { # qq * *
3671 0           my $delimiter = $1;
3672 0           my $qq_string = '';
3673 0           while (not /\G \z/oxgc) {
3674 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3675 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3676 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3677 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3678             }
3679 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3680             }
3681             }
3682 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3683             }
3684             }
3685              
3686             # qr//
3687             elsif (/\G \b (qr) \b /oxgc) {
3688 0           my $ope = $1;
3689 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
3690 0           return e_qr($ope,$1,$3,$2,$4);
3691             }
3692             else {
3693 0           my $e = '';
3694 0           while (not /\G \z/oxgc) {
3695 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3696 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3697 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3698 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3699 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3700 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3701 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3702 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3703             }
3704 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3705             }
3706             }
3707              
3708             # qw//
3709             elsif (/\G \b (qw) \b /oxgc) {
3710 0           my $ope = $1;
3711 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3712 0           return e_qw($ope,$1,$3,$2);
3713             }
3714             else {
3715 0           my $e = '';
3716 0           while (not /\G \z/oxgc) {
3717 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3718              
3719 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3720 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3721              
3722 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3723 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3724              
3725 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3726 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3727              
3728 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3729 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3730              
3731 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3732 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3733             }
3734 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3735             }
3736             }
3737              
3738             # qx//
3739             elsif (/\G \b (qx) \b /oxgc) {
3740 0           my $ope = $1;
3741 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3742 0           return e_qq($ope,$1,$3,$2);
3743             }
3744             else {
3745 0           my $e = '';
3746 0           while (not /\G \z/oxgc) {
3747 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3748 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3749 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3750 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3751 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3752 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3753 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3754             }
3755 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3756             }
3757             }
3758              
3759             # q//
3760             elsif (/\G \b (q) \b /oxgc) {
3761 0           my $ope = $1;
3762              
3763             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3764              
3765             # avoid "Error: Runtime exception" of perl version 5.005_03
3766             # (and so on)
3767              
3768 0 0         if (/\G (\#) /oxgc) { # q# #
3769 0           my $q_string = '';
3770 0           while (not /\G \z/oxgc) {
3771 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3772 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3773 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3774 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3775             }
3776 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3777             }
3778              
3779             else {
3780 0           my $e = '';
3781 0           while (not /\G \z/oxgc) {
3782 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3783              
3784             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3785             elsif (/\G (\() /oxgc) { # q ( )
3786 0           my $q_string = '';
3787 0           local $nest = 1;
3788 0           while (not /\G \z/oxgc) {
3789 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3790 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3791 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3792 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3793             elsif (/\G (\)) /oxgc) {
3794 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3795 0           else { $q_string .= $1; }
3796             }
3797 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3798             }
3799 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3800             }
3801              
3802             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3803             elsif (/\G (\{) /oxgc) { # q { }
3804 0           my $q_string = '';
3805 0           local $nest = 1;
3806 0           while (not /\G \z/oxgc) {
3807 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3808 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3809 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3810 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3811             elsif (/\G (\}) /oxgc) {
3812 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3813 0           else { $q_string .= $1; }
3814             }
3815 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3816             }
3817 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3818             }
3819              
3820             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3821             elsif (/\G (\[) /oxgc) { # q [ ]
3822 0           my $q_string = '';
3823 0           local $nest = 1;
3824 0           while (not /\G \z/oxgc) {
3825 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3826 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3827 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3828 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3829             elsif (/\G (\]) /oxgc) {
3830 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3831 0           else { $q_string .= $1; }
3832             }
3833 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3834             }
3835 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3836             }
3837              
3838             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3839             elsif (/\G (\<) /oxgc) { # q < >
3840 0           my $q_string = '';
3841 0           local $nest = 1;
3842 0           while (not /\G \z/oxgc) {
3843 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3844 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3845 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3846 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3847             elsif (/\G (\>) /oxgc) {
3848 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3849 0           else { $q_string .= $1; }
3850             }
3851 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3852             }
3853 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3854             }
3855              
3856             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3857             elsif (/\G (\S) /oxgc) { # q * *
3858 0           my $delimiter = $1;
3859 0           my $q_string = '';
3860 0           while (not /\G \z/oxgc) {
3861 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3862 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3863 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3864 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3865             }
3866 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3867             }
3868             }
3869 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3870             }
3871             }
3872              
3873             # m//
3874             elsif (/\G \b (m) \b /oxgc) {
3875 0           my $ope = $1;
3876 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
3877 0           return e_qr($ope,$1,$3,$2,$4);
3878             }
3879             else {
3880 0           my $e = '';
3881 0           while (not /\G \z/oxgc) {
3882 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3883 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3884 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3885 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3886 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3887 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3888 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3889 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3890 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3891             }
3892 0           die __FILE__, ": Search pattern not terminated";
3893             }
3894             }
3895              
3896             # s///
3897              
3898             # about [cegimosxpradlubB]* (/cg modifier)
3899             #
3900             # P.67 Pattern-Matching Operators
3901             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3902              
3903             elsif (/\G \b (s) \b /oxgc) {
3904 0           my $ope = $1;
3905              
3906             # $1 $2 $3 $4 $5 $6
3907 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
3908 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3909             }
3910             else {
3911 0           my $e = '';
3912 0           while (not /\G \z/oxgc) {
3913 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3914             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3915 0           my @s = ($1,$2,$3);
3916 0           while (not /\G \z/oxgc) {
3917 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3918             # $1 $2 $3 $4
3919 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3920 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3921 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3922 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3923 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928             }
3929 0           die __FILE__, ": Substitution replacement not terminated";
3930             }
3931             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3932 0           my @s = ($1,$2,$3);
3933 0           while (not /\G \z/oxgc) {
3934 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3935             # $1 $2 $3 $4
3936 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945             }
3946 0           die __FILE__, ": Substitution replacement not terminated";
3947             }
3948             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3949 0           my @s = ($1,$2,$3);
3950 0           while (not /\G \z/oxgc) {
3951 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3952             # $1 $2 $3 $4
3953 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960             }
3961 0           die __FILE__, ": Substitution replacement not terminated";
3962             }
3963             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3964 0           my @s = ($1,$2,$3);
3965 0           while (not /\G \z/oxgc) {
3966 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3967             # $1 $2 $3 $4
3968 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3971 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977             }
3978 0           die __FILE__, ": Substitution replacement not terminated";
3979             }
3980             # $1 $2 $3 $4 $5 $6
3981             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
3982 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3983             }
3984             # $1 $2 $3 $4 $5 $6
3985             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3986 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3987             }
3988             # $1 $2 $3 $4 $5 $6
3989             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3990 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3991             }
3992             # $1 $2 $3 $4 $5 $6
3993             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3994 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3995             }
3996             }
3997 0           die __FILE__, ": Substitution pattern not terminated";
3998             }
3999             }
4000              
4001             # require ignore module
4002 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4003 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4004 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4005              
4006             # use strict; --> use strict; no strict qw(refs);
4007 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4008 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4009 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4010              
4011             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4012             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
4013 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
4014 0           return "use $1; no strict qw(refs);";
4015             }
4016             else {
4017 0           return "use $1;";
4018             }
4019             }
4020             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
4021 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4022 0           return "use $1; no strict qw(refs);";
4023             }
4024             else {
4025 0           return "use $1;";
4026             }
4027             }
4028              
4029             # ignore use module
4030 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4031 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4032 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4033              
4034             # ignore no module
4035 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4036 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4037 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4038              
4039             # use else
4040 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4041              
4042             # use else
4043 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4044              
4045             # ''
4046             elsif (/\G (?
4047 0           my $q_string = '';
4048 0           while (not /\G \z/oxgc) {
4049 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4050 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4051 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4052 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4053             }
4054 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4055             }
4056              
4057             # ""
4058             elsif (/\G (\") /oxgc) {
4059 0           my $qq_string = '';
4060 0           while (not /\G \z/oxgc) {
4061 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4062 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4063 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4064 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4065             }
4066 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4067             }
4068              
4069             # ``
4070             elsif (/\G (\`) /oxgc) {
4071 0           my $qx_string = '';
4072 0           while (not /\G \z/oxgc) {
4073 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4074 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4075 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4076 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4077             }
4078 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4079             }
4080              
4081             # // --- not divide operator (num / num), not defined-or
4082             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4083 0           my $regexp = '';
4084 0           while (not /\G \z/oxgc) {
4085 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4086 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4087 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4088 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4089             }
4090 0           die __FILE__, ": Search pattern not terminated";
4091             }
4092              
4093             # ?? --- not conditional operator (condition ? then : else)
4094             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4095 0           my $regexp = '';
4096 0           while (not /\G \z/oxgc) {
4097 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4098 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4099 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4100 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4101             }
4102 0           die __FILE__, ": Search pattern not terminated";
4103             }
4104              
4105             # << (bit shift) --- not here document
4106 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4107              
4108             # <<'HEREDOC'
4109             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4110 0           $slash = 'm//';
4111 0           my $here_quote = $1;
4112 0           my $delimiter = $2;
4113              
4114             # get here document
4115 0 0         if ($here_script eq '') {
4116 0           $here_script = CORE::substr $_, pos $_;
4117 0           $here_script =~ s/.*?\n//oxm;
4118             }
4119 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4120 0           push @heredoc, $1 . qq{\n$delimiter\n};
4121 0           push @heredoc_delimiter, $delimiter;
4122             }
4123             else {
4124 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4125             }
4126 0           return $here_quote;
4127             }
4128              
4129             # <<\HEREDOC
4130              
4131             # P.66 2.6.6. "Here" Documents
4132             # in Chapter 2: Bits and Pieces
4133             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4134              
4135             # P.73 "Here" Documents
4136             # in Chapter 2: Bits and Pieces
4137             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4138              
4139             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4140 0           $slash = 'm//';
4141 0           my $here_quote = $1;
4142 0           my $delimiter = $2;
4143              
4144             # get here document
4145 0 0         if ($here_script eq '') {
4146 0           $here_script = CORE::substr $_, pos $_;
4147 0           $here_script =~ s/.*?\n//oxm;
4148             }
4149 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4150 0           push @heredoc, $1 . qq{\n$delimiter\n};
4151 0           push @heredoc_delimiter, $delimiter;
4152             }
4153             else {
4154 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4155             }
4156 0           return $here_quote;
4157             }
4158              
4159             # <<"HEREDOC"
4160             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4161 0           $slash = 'm//';
4162 0           my $here_quote = $1;
4163 0           my $delimiter = $2;
4164              
4165             # get here document
4166 0 0         if ($here_script eq '') {
4167 0           $here_script = CORE::substr $_, pos $_;
4168 0           $here_script =~ s/.*?\n//oxm;
4169             }
4170 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4171 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4172 0           push @heredoc_delimiter, $delimiter;
4173             }
4174             else {
4175 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4176             }
4177 0           return $here_quote;
4178             }
4179              
4180             # <
4181             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4182 0           $slash = 'm//';
4183 0           my $here_quote = $1;
4184 0           my $delimiter = $2;
4185              
4186             # get here document
4187 0 0         if ($here_script eq '') {
4188 0           $here_script = CORE::substr $_, pos $_;
4189 0           $here_script =~ s/.*?\n//oxm;
4190             }
4191 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4192 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4193 0           push @heredoc_delimiter, $delimiter;
4194             }
4195             else {
4196 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4197             }
4198 0           return $here_quote;
4199             }
4200              
4201             # <<`HEREDOC`
4202             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4203 0           $slash = 'm//';
4204 0           my $here_quote = $1;
4205 0           my $delimiter = $2;
4206              
4207             # get here document
4208 0 0         if ($here_script eq '') {
4209 0           $here_script = CORE::substr $_, pos $_;
4210 0           $here_script =~ s/.*?\n//oxm;
4211             }
4212 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4213 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4214 0           push @heredoc_delimiter, $delimiter;
4215             }
4216             else {
4217 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4218             }
4219 0           return $here_quote;
4220             }
4221              
4222             # <<= <=> <= < operator
4223             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4224 0           return $1;
4225             }
4226              
4227             #
4228             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4229 0           return $1;
4230             }
4231              
4232             # --- glob
4233              
4234             # avoid "Error: Runtime exception" of perl version 5.005_03
4235              
4236             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4237 0           return 'Char::Elatin8::glob("' . $1 . '")';
4238             }
4239              
4240             # __DATA__
4241 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4242              
4243             # __END__
4244 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4245              
4246             # \cD Control-D
4247              
4248             # P.68 2.6.8. Other Literal Tokens
4249             # in Chapter 2: Bits and Pieces
4250             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4251              
4252             # P.76 Other Literal Tokens
4253             # in Chapter 2: Bits and Pieces
4254             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4255              
4256 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4257              
4258             # \cZ Control-Z
4259 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4260              
4261             # any operator before div
4262             elsif (/\G (
4263             -- | \+\+ |
4264             [\)\}\]]
4265              
4266 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4267              
4268             # yada-yada or triple-dot operator
4269             elsif (/\G (
4270             \.\.\.
4271              
4272 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4273              
4274             # any operator before m//
4275              
4276             # //, //= (defined-or)
4277              
4278             # P.164 Logical Operators
4279             # in Chapter 10: More Control Structures
4280             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4281              
4282             # P.119 C-Style Logical (Short-Circuit) Operators
4283             # in Chapter 3: Unary and Binary Operators
4284             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4285              
4286             # (and so on)
4287              
4288             # ~~
4289              
4290             # P.221 The Smart Match Operator
4291             # in Chapter 15: Smart Matching and given-when
4292             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4293              
4294             # P.112 Smartmatch Operator
4295             # in Chapter 3: Unary and Binary Operators
4296             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4297              
4298             # (and so on)
4299              
4300             elsif (/\G (
4301              
4302             !~~ | !~ | != | ! |
4303             %= | % |
4304             &&= | && | &= | & |
4305             -= | -> | - |
4306             :\s*= |
4307             : |
4308             <<= | <=> | <= | < |
4309             == | => | =~ | = |
4310             >>= | >> | >= | > |
4311             \*\*= | \*\* | \*= | \* |
4312             \+= | \+ |
4313             \.\. | \.= | \. |
4314             \/\/= | \/\/ |
4315             \/= | \/ |
4316             \? |
4317             \\ |
4318             \^= | \^ |
4319             \b x= |
4320             \|\|= | \|\| | \|= | \| |
4321             ~~ | ~ |
4322             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4323             \b(?: print )\b |
4324              
4325             [,;\(\{\[]
4326              
4327 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4328              
4329             # other any character
4330 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4331              
4332             # system error
4333             else {
4334 0           die __FILE__, ": Oops, this shouldn't happen!";
4335             }
4336             }
4337              
4338             # escape Latin-8 string
4339             sub e_string {
4340 0     0 0   my($string) = @_;
4341 0           my $e_string = '';
4342              
4343 0           local $slash = 'm//';
4344              
4345             # P.1024 Appendix W.10 Multibyte Processing
4346             # of ISBN 1-56592-224-7 CJKV Information Processing
4347             # (and so on)
4348              
4349 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
4350              
4351             # without { ... }
4352 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4353 0 0         if ($string !~ /<
4354 0           return $string;
4355             }
4356             }
4357              
4358             E_STRING_LOOP:
4359 0           while ($string !~ /\G \z/oxgc) {
4360 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4361             }
4362              
4363             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Elatin8::PREMATCH()]}
4364 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
4365 0           $e_string .= q{Char::Elatin8::PREMATCH()};
4366 0           $slash = 'div';
4367             }
4368              
4369             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Elatin8::MATCH()]}
4370             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
4371 0           $e_string .= q{Char::Elatin8::MATCH()};
4372 0           $slash = 'div';
4373             }
4374              
4375             # $', ${'} --> $', ${'}
4376             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4377 0           $e_string .= $1;
4378 0           $slash = 'div';
4379             }
4380              
4381             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Elatin8::POSTMATCH()]}
4382             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
4383 0           $e_string .= q{Char::Elatin8::POSTMATCH()};
4384 0           $slash = 'div';
4385             }
4386              
4387             # bareword
4388             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
4389 0           $e_string .= $1;
4390 0           $slash = 'div';
4391             }
4392              
4393             # $0 --> $0
4394             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4395 0           $e_string .= $1;
4396 0           $slash = 'div';
4397             }
4398             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
4399 0           $e_string .= $1;
4400 0           $slash = 'div';
4401             }
4402              
4403             # $$ --> $$
4404             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4405 0           $e_string .= $1;
4406 0           $slash = 'div';
4407             }
4408              
4409             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4410             # $1, $2, $3 --> $1, $2, $3 otherwise
4411             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
4412 0           $e_string .= e_capture($1);
4413 0           $slash = 'div';
4414             }
4415             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
4416 0           $e_string .= e_capture($1);
4417 0           $slash = 'div';
4418             }
4419              
4420             # $$foo[ ... ] --> $ $foo->[ ... ]
4421             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
4422 0           $e_string .= e_capture($1.'->'.$2);
4423 0           $slash = 'div';
4424             }
4425              
4426             # $$foo{ ... } --> $ $foo->{ ... }
4427             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
4428 0           $e_string .= e_capture($1.'->'.$2);
4429 0           $slash = 'div';
4430             }
4431              
4432             # $$foo
4433             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
4434 0           $e_string .= e_capture($1);
4435 0           $slash = 'div';
4436             }
4437              
4438             # ${ foo }
4439             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
4440 0           $e_string .= '${' . $1 . '}';
4441 0           $slash = 'div';
4442             }
4443              
4444             # ${ ... }
4445             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
4446 0           $e_string .= e_capture($1);
4447 0           $slash = 'div';
4448             }
4449              
4450             # variable or function
4451             # $ @ % & * $ #
4452             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) {
4453 0           $e_string .= $1;
4454 0           $slash = 'div';
4455             }
4456             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4457             # $ @ # \ ' " / ? ( ) [ ] < >
4458             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4459 0           $e_string .= $1;
4460 0           $slash = 'div';
4461             }
4462              
4463             # subroutines of package Char::Elatin8
4464 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4465 0           elsif ($string =~ /\G \b Char::Latin8::eval (?= \s* \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4466 0           elsif ($string =~ /\G \b Char::Latin8::eval \b /oxgc) { $e_string .= 'eval Char::Latin8::escape'; $slash = 'm//'; }
  0            
4467 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4468 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Elatin8::chop'; $slash = 'm//'; }
  0            
4469 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4470 0           elsif ($string =~ /\G \b Char::Latin8::index \b /oxgc) { $e_string .= 'Char::Latin8::index'; $slash = 'm//'; }
  0            
4471 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Elatin8::index'; $slash = 'm//'; }
  0            
4472 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4473 0           elsif ($string =~ /\G \b Char::Latin8::rindex \b /oxgc) { $e_string .= 'Char::Latin8::rindex'; $slash = 'm//'; }
  0            
4474 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Elatin8::rindex'; $slash = 'm//'; }
  0            
4475 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin8::lc'; $slash = 'm//'; }
  0            
4476 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin8::lcfirst'; $slash = 'm//'; }
  0            
4477 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin8::uc'; $slash = 'm//'; }
  0            
4478 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin8::ucfirst'; $slash = 'm//'; }
  0            
4479 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin8::fc'; $slash = 'm//'; }
  0            
4480              
4481             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4482 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4483 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4484 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4485 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4486 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4487 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4488 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            
4489              
4490 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4491 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4492 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4493 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4494 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4495 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4496 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            
4497              
4498             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
4499 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4500 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4501 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4502 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4503              
4504 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4505 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4506 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin8::chr'; $slash = 'm//'; }
  0            
4507 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4508 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4509 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin8::glob'; $slash = 'm//'; }
  0            
4510 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Elatin8::lc_'; $slash = 'm//'; }
  0            
4511 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Elatin8::lcfirst_'; $slash = 'm//'; }
  0            
4512 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Elatin8::uc_'; $slash = 'm//'; }
  0            
4513 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Elatin8::ucfirst_'; $slash = 'm//'; }
  0            
4514 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Elatin8::fc_'; $slash = 'm//'; }
  0            
4515 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4516              
4517 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4518 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4519 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Elatin8::chr_'; $slash = 'm//'; }
  0            
4520 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4521 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4522 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Elatin8::glob_'; $slash = 'm//'; }
  0            
4523 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4524 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4525             # split
4526             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
4527 0           $slash = 'm//';
4528              
4529 0           my $e = '';
4530 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
4531 0           $e .= $1;
4532             }
4533              
4534             # end of split
4535 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::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          
4536              
4537             # split scalar value
4538 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4539              
4540             # split literal space
4541 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4542 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4543 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4544 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4545 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4546 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4547 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4548 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4549 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4550 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4551 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4552 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4553 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4554 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Elatin8::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4555              
4556             # split qq//
4557             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4558 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            
4559             else {
4560 0           while ($string !~ /\G \z/oxgc) {
4561 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4562 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4563 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4564 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4565 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4566 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4567 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            
4568             }
4569 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4570             }
4571             }
4572              
4573             # split qr//
4574             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4575 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
4576             else {
4577 0           while ($string !~ /\G \z/oxgc) {
4578 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4579 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4580 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4581 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4582 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4583 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0            
4584 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4585 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0            
4586             }
4587 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4588             }
4589             }
4590              
4591             # split q//
4592             elsif ($string =~ /\G \b (q) \b /oxgc) {
4593 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            
4594             else {
4595 0           while ($string !~ /\G \z/oxgc) {
4596 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4597 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4598 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4599 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4600 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4601 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4602 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            
4603             }
4604 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4605             }
4606             }
4607              
4608             # split m//
4609             elsif ($string =~ /\G \b (m) \b /oxgc) {
4610 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0            
  0            
4611             else {
4612 0           while ($string !~ /\G \z/oxgc) {
4613 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4614 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0            
4615 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0            
4616 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0            
4617 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0            
4618 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0            
4619 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4620 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0            
4621             }
4622 0           die __FILE__, ": Search pattern not terminated";
4623             }
4624             }
4625              
4626             # split ''
4627             elsif ($string =~ /\G (\') /oxgc) {
4628 0           my $q_string = '';
4629 0           while ($string !~ /\G \z/oxgc) {
4630 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4631 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4632 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4633 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4634             }
4635 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4636             }
4637              
4638             # split ""
4639             elsif ($string =~ /\G (\") /oxgc) {
4640 0           my $qq_string = '';
4641 0           while ($string !~ /\G \z/oxgc) {
4642 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4643 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4644 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4645 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4646             }
4647 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4648             }
4649              
4650             # split //
4651             elsif ($string =~ /\G (\/) /oxgc) {
4652 0           my $regexp = '';
4653 0           while ($string !~ /\G \z/oxgc) {
4654 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4655 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4656 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4657 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4658             }
4659 0           die __FILE__, ": Search pattern not terminated";
4660             }
4661             }
4662              
4663             # qq//
4664             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4665 0           my $ope = $1;
4666 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4667 0           $e_string .= e_qq($ope,$1,$3,$2);
4668             }
4669             else {
4670 0           my $e = '';
4671 0           while ($string !~ /\G \z/oxgc) {
4672 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4673 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4674 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4675 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4676 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4677 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4678             }
4679 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4680             }
4681             }
4682              
4683             # qx//
4684             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4685 0           my $ope = $1;
4686 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4687 0           $e_string .= e_qq($ope,$1,$3,$2);
4688             }
4689             else {
4690 0           my $e = '';
4691 0           while ($string !~ /\G \z/oxgc) {
4692 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4693 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4694 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4695 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4696 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4697 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4698 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4699             }
4700 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4701             }
4702             }
4703              
4704             # q//
4705             elsif ($string =~ /\G \b (q) \b /oxgc) {
4706 0           my $ope = $1;
4707 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4708 0           $e_string .= e_q($ope,$1,$3,$2);
4709             }
4710             else {
4711 0           my $e = '';
4712 0           while ($string !~ /\G \z/oxgc) {
4713 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4714 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4715 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4716 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4717 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4718 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            
4719             }
4720 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4721             }
4722             }
4723              
4724             # ''
4725 0           elsif ($string =~ /\G (?
4726              
4727             # ""
4728 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4729              
4730             # ``
4731 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4732              
4733             # <<= <=> <= < operator
4734             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
4735 0           { $e_string .= $1; }
4736              
4737             #
4738 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4739              
4740             # --- glob
4741             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4742 0           $e_string .= 'Char::Elatin8::glob("' . $1 . '")';
4743             }
4744              
4745             # << (bit shift) --- not here document
4746 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4747              
4748             # <<'HEREDOC'
4749             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4750 0           $slash = 'm//';
4751 0           my $here_quote = $1;
4752 0           my $delimiter = $2;
4753              
4754             # get here document
4755 0 0         if ($here_script eq '') {
4756 0           $here_script = CORE::substr $_, pos $_;
4757 0           $here_script =~ s/.*?\n//oxm;
4758             }
4759 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4760 0           push @heredoc, $1 . qq{\n$delimiter\n};
4761 0           push @heredoc_delimiter, $delimiter;
4762             }
4763             else {
4764 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4765             }
4766 0           $e_string .= $here_quote;
4767             }
4768              
4769             # <<\HEREDOC
4770             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4771 0           $slash = 'm//';
4772 0           my $here_quote = $1;
4773 0           my $delimiter = $2;
4774              
4775             # get here document
4776 0 0         if ($here_script eq '') {
4777 0           $here_script = CORE::substr $_, pos $_;
4778 0           $here_script =~ s/.*?\n//oxm;
4779             }
4780 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4781 0           push @heredoc, $1 . qq{\n$delimiter\n};
4782 0           push @heredoc_delimiter, $delimiter;
4783             }
4784             else {
4785 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4786             }
4787 0           $e_string .= $here_quote;
4788             }
4789              
4790             # <<"HEREDOC"
4791             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4792 0           $slash = 'm//';
4793 0           my $here_quote = $1;
4794 0           my $delimiter = $2;
4795              
4796             # get here document
4797 0 0         if ($here_script eq '') {
4798 0           $here_script = CORE::substr $_, pos $_;
4799 0           $here_script =~ s/.*?\n//oxm;
4800             }
4801 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4802 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4803 0           push @heredoc_delimiter, $delimiter;
4804             }
4805             else {
4806 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4807             }
4808 0           $e_string .= $here_quote;
4809             }
4810              
4811             # <
4812             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4813 0           $slash = 'm//';
4814 0           my $here_quote = $1;
4815 0           my $delimiter = $2;
4816              
4817             # get here document
4818 0 0         if ($here_script eq '') {
4819 0           $here_script = CORE::substr $_, pos $_;
4820 0           $here_script =~ s/.*?\n//oxm;
4821             }
4822 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4823 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4824 0           push @heredoc_delimiter, $delimiter;
4825             }
4826             else {
4827 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4828             }
4829 0           $e_string .= $here_quote;
4830             }
4831              
4832             # <<`HEREDOC`
4833             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4834 0           $slash = 'm//';
4835 0           my $here_quote = $1;
4836 0           my $delimiter = $2;
4837              
4838             # get here document
4839 0 0         if ($here_script eq '') {
4840 0           $here_script = CORE::substr $_, pos $_;
4841 0           $here_script =~ s/.*?\n//oxm;
4842             }
4843 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4844 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4845 0           push @heredoc_delimiter, $delimiter;
4846             }
4847             else {
4848 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4849             }
4850 0           $e_string .= $here_quote;
4851             }
4852              
4853             # any operator before div
4854             elsif ($string =~ /\G (
4855             -- | \+\+ |
4856             [\)\}\]]
4857              
4858 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4859              
4860             # yada-yada or triple-dot operator
4861             elsif ($string =~ /\G (
4862             \.\.\.
4863              
4864 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4865              
4866             # any operator before m//
4867             elsif ($string =~ /\G (
4868              
4869             !~~ | !~ | != | ! |
4870             %= | % |
4871             &&= | && | &= | & |
4872             -= | -> | - |
4873             :\s*= |
4874             : |
4875             <<= | <=> | <= | < |
4876             == | => | =~ | = |
4877             >>= | >> | >= | > |
4878             \*\*= | \*\* | \*= | \* |
4879             \+= | \+ |
4880             \.\. | \.= | \. |
4881             \/\/= | \/\/ |
4882             \/= | \/ |
4883             \? |
4884             \\ |
4885             \^= | \^ |
4886             \b x= |
4887             \|\|= | \|\| | \|= | \| |
4888             ~~ | ~ |
4889             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4890             \b(?: print )\b |
4891              
4892             [,;\(\{\[]
4893              
4894 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4895              
4896             # other any character
4897 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4898              
4899             # system error
4900             else {
4901 0           die __FILE__, ": Oops, this shouldn't happen!";
4902             }
4903             }
4904              
4905 0           return $e_string;
4906             }
4907              
4908             #
4909             # character class
4910             #
4911             sub character_class {
4912 0     0 0   my($char,$modifier) = @_;
4913              
4914 0 0         if ($char eq '.') {
4915 0 0         if ($modifier =~ /s/) {
4916 0           return '${Char::Elatin8::dot_s}';
4917             }
4918             else {
4919 0           return '${Char::Elatin8::dot}';
4920             }
4921             }
4922             else {
4923 0           return Char::Elatin8::classic_character_class($char);
4924             }
4925             }
4926              
4927             #
4928             # escape capture ($1, $2, $3, ...)
4929             #
4930             sub e_capture {
4931              
4932 0     0 0   return join '', '${', $_[0], '}';
4933             }
4934              
4935             #
4936             # escape transliteration (tr/// or y///)
4937             #
4938             sub e_tr {
4939 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4940 0           my $e_tr = '';
4941 0   0       $modifier ||= '';
4942              
4943 0           $slash = 'div';
4944              
4945             # quote character class 1
4946 0           $charclass = q_tr($charclass);
4947              
4948             # quote character class 2
4949 0           $charclass2 = q_tr($charclass2);
4950              
4951             # /b /B modifier
4952 0 0         if ($modifier =~ tr/bB//d) {
4953 0 0         if ($variable eq '') {
4954 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4955             }
4956             else {
4957 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4958             }
4959             }
4960             else {
4961 0 0         if ($variable eq '') {
4962 0           $e_tr = qq{Char::Elatin8::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4963             }
4964             else {
4965 0           $e_tr = qq{Char::Elatin8::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4966             }
4967             }
4968              
4969             # clear tr/// variable
4970 0           $tr_variable = '';
4971 0           $bind_operator = '';
4972              
4973 0           return $e_tr;
4974             }
4975              
4976             #
4977             # quote for escape transliteration (tr/// or y///)
4978             #
4979             sub q_tr {
4980 0     0 0   my($charclass) = @_;
4981              
4982             # quote character class
4983 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4984 0           return e_q('', "'", "'", $charclass); # --> q' '
4985             }
4986             elsif ($charclass !~ /\//oxms) {
4987 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4988             }
4989             elsif ($charclass !~ /\#/oxms) {
4990 0           return e_q('q', '#', '#', $charclass); # --> q# #
4991             }
4992             elsif ($charclass !~ /[\<\>]/oxms) {
4993 0           return e_q('q', '<', '>', $charclass); # --> q< >
4994             }
4995             elsif ($charclass !~ /[\(\)]/oxms) {
4996 0           return e_q('q', '(', ')', $charclass); # --> q( )
4997             }
4998             elsif ($charclass !~ /[\{\}]/oxms) {
4999 0           return e_q('q', '{', '}', $charclass); # --> q{ }
5000             }
5001             else {
5002 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5003 0 0         if ($charclass !~ /\Q$char\E/xms) {
5004 0           return e_q('q', $char, $char, $charclass);
5005             }
5006             }
5007             }
5008              
5009 0           return e_q('q', '{', '}', $charclass);
5010             }
5011              
5012             #
5013             # escape q string (q//, '')
5014             #
5015             sub e_q {
5016 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5017              
5018 0           $slash = 'div';
5019              
5020 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5021             }
5022              
5023             #
5024             # escape qq string (qq//, "", qx//, ``)
5025             #
5026             sub e_qq {
5027 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5028              
5029 0           $slash = 'div';
5030              
5031 0           my $left_e = 0;
5032 0           my $right_e = 0;
5033 0           my @char = $string =~ /\G(
5034             \\o\{ [0-7]+ \} |
5035             \\x\{ [0-9A-Fa-f]+ \} |
5036             \\N\{ [^0-9\}][^\}]* \} |
5037             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5038             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5039             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5040             \$ \s* \d+ |
5041             \$ \s* \{ \s* \d+ \s* \} |
5042             \$ \$ (?![\w\{]) |
5043             \$ \s* \$ \s* $qq_variable |
5044             \\?(?:$q_char)
5045             )/oxmsg;
5046              
5047 0           for (my $i=0; $i <= $#char; $i++) {
5048              
5049             # "\L\u" --> "\u\L"
5050 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5051 0           @char[$i,$i+1] = @char[$i+1,$i];
5052             }
5053              
5054             # "\U\l" --> "\l\U"
5055             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5056 0           @char[$i,$i+1] = @char[$i+1,$i];
5057             }
5058              
5059             # octal escape sequence
5060             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5061 0           $char[$i] = Char::Elatin8::octchr($1);
5062             }
5063              
5064             # hexadecimal escape sequence
5065             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5066 0           $char[$i] = Char::Elatin8::hexchr($1);
5067             }
5068              
5069             # \N{CHARNAME} --> N{CHARNAME}
5070             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5071 0           $char[$i] = $1;
5072             }
5073              
5074 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5075             }
5076              
5077             # \F
5078             #
5079             # P.69 Table 2-6. Translation escapes
5080             # in Chapter 2: Bits and Pieces
5081             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5082             # (and so on)
5083              
5084             # \u \l \U \L \F \Q \E
5085 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5086 0 0         if ($right_e < $left_e) {
5087 0           $char[$i] = '\\' . $char[$i];
5088             }
5089             }
5090             elsif ($char[$i] eq '\u') {
5091              
5092             # "STRING @{[ LIST EXPR ]} MORE STRING"
5093              
5094             # P.257 Other Tricks You Can Do with Hard References
5095             # in Chapter 8: References
5096             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5097              
5098             # P.353 Other Tricks You Can Do with Hard References
5099             # in Chapter 8: References
5100             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5101              
5102             # (and so on)
5103              
5104 0           $char[$i] = '@{[Char::Elatin8::ucfirst qq<';
5105 0           $left_e++;
5106             }
5107             elsif ($char[$i] eq '\l') {
5108 0           $char[$i] = '@{[Char::Elatin8::lcfirst qq<';
5109 0           $left_e++;
5110             }
5111             elsif ($char[$i] eq '\U') {
5112 0           $char[$i] = '@{[Char::Elatin8::uc qq<';
5113 0           $left_e++;
5114             }
5115             elsif ($char[$i] eq '\L') {
5116 0           $char[$i] = '@{[Char::Elatin8::lc qq<';
5117 0           $left_e++;
5118             }
5119             elsif ($char[$i] eq '\F') {
5120 0           $char[$i] = '@{[Char::Elatin8::fc qq<';
5121 0           $left_e++;
5122             }
5123             elsif ($char[$i] eq '\Q') {
5124 0           $char[$i] = '@{[CORE::quotemeta qq<';
5125 0           $left_e++;
5126             }
5127             elsif ($char[$i] eq '\E') {
5128 0 0         if ($right_e < $left_e) {
5129 0           $char[$i] = '>]}';
5130 0           $right_e++;
5131             }
5132             else {
5133 0           $char[$i] = '';
5134             }
5135             }
5136             elsif ($char[$i] eq '\Q') {
5137 0           while (1) {
5138 0 0         if (++$i > $#char) {
5139 0           last;
5140             }
5141 0 0         if ($char[$i] eq '\E') {
5142 0           last;
5143             }
5144             }
5145             }
5146             elsif ($char[$i] eq '\E') {
5147             }
5148              
5149             # $0 --> $0
5150             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5151             }
5152             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5153             }
5154              
5155             # $$ --> $$
5156             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5157             }
5158              
5159             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5160             # $1, $2, $3 --> $1, $2, $3 otherwise
5161             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5162 0           $char[$i] = e_capture($1);
5163             }
5164             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5165 0           $char[$i] = e_capture($1);
5166             }
5167              
5168             # $$foo[ ... ] --> $ $foo->[ ... ]
5169             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5170 0           $char[$i] = e_capture($1.'->'.$2);
5171             }
5172              
5173             # $$foo{ ... } --> $ $foo->{ ... }
5174             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5175 0           $char[$i] = e_capture($1.'->'.$2);
5176             }
5177              
5178             # $$foo
5179             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5180 0           $char[$i] = e_capture($1);
5181             }
5182              
5183             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin8::PREMATCH()
5184             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5185 0           $char[$i] = '@{[Char::Elatin8::PREMATCH()]}';
5186             }
5187              
5188             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin8::MATCH()
5189             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5190 0           $char[$i] = '@{[Char::Elatin8::MATCH()]}';
5191             }
5192              
5193             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin8::POSTMATCH()
5194             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5195 0           $char[$i] = '@{[Char::Elatin8::POSTMATCH()]}';
5196             }
5197              
5198             # ${ foo } --> ${ foo }
5199             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5200             }
5201              
5202             # ${ ... }
5203             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5204 0           $char[$i] = e_capture($1);
5205             }
5206             }
5207              
5208             # return string
5209 0 0         if ($left_e > $right_e) {
5210 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5211             }
5212 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5213             }
5214              
5215             #
5216             # escape qw string (qw//)
5217             #
5218             sub e_qw {
5219 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5220              
5221 0           $slash = 'div';
5222              
5223             # choice again delimiter
5224 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5225 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5226 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5227             }
5228             elsif (not $octet{')'}) {
5229 0           return join '', $ope, '(', $string, ')';
5230             }
5231             elsif (not $octet{'}'}) {
5232 0           return join '', $ope, '{', $string, '}';
5233             }
5234             elsif (not $octet{']'}) {
5235 0           return join '', $ope, '[', $string, ']';
5236             }
5237             elsif (not $octet{'>'}) {
5238 0           return join '', $ope, '<', $string, '>';
5239             }
5240             else {
5241 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5242 0 0         if (not $octet{$char}) {
5243 0           return join '', $ope, $char, $string, $char;
5244             }
5245             }
5246             }
5247              
5248             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5249 0           my @string = CORE::split(/\s+/, $string);
5250 0           for my $string (@string) {
5251 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5252 0           for my $octet (@octet) {
5253 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5254 0           $octet = '\\' . $1;
5255             }
5256             }
5257 0           $string = join '', @octet;
5258             }
5259 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5260             }
5261              
5262             #
5263             # escape here document (<<"HEREDOC", <
5264             #
5265             sub e_heredoc {
5266 0     0 0   my($string) = @_;
5267              
5268 0           $slash = 'm//';
5269              
5270 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5271              
5272 0           my $left_e = 0;
5273 0           my $right_e = 0;
5274 0           my @char = $string =~ /\G(
5275             \\o\{ [0-7]+ \} |
5276             \\x\{ [0-9A-Fa-f]+ \} |
5277             \\N\{ [^0-9\}][^\}]* \} |
5278             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5279             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5280             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5281             \$ \s* \d+ |
5282             \$ \s* \{ \s* \d+ \s* \} |
5283             \$ \$ (?![\w\{]) |
5284             \$ \s* \$ \s* $qq_variable |
5285             \\?(?:$q_char)
5286             )/oxmsg;
5287              
5288 0           for (my $i=0; $i <= $#char; $i++) {
5289              
5290             # "\L\u" --> "\u\L"
5291 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5292 0           @char[$i,$i+1] = @char[$i+1,$i];
5293             }
5294              
5295             # "\U\l" --> "\l\U"
5296             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5297 0           @char[$i,$i+1] = @char[$i+1,$i];
5298             }
5299              
5300             # octal escape sequence
5301             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5302 0           $char[$i] = Char::Elatin8::octchr($1);
5303             }
5304              
5305             # hexadecimal escape sequence
5306             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5307 0           $char[$i] = Char::Elatin8::hexchr($1);
5308             }
5309              
5310             # \N{CHARNAME} --> N{CHARNAME}
5311             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5312 0           $char[$i] = $1;
5313             }
5314              
5315 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5316             }
5317              
5318             # \u \l \U \L \F \Q \E
5319 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5320 0 0         if ($right_e < $left_e) {
5321 0           $char[$i] = '\\' . $char[$i];
5322             }
5323             }
5324             elsif ($char[$i] eq '\u') {
5325 0           $char[$i] = '@{[Char::Elatin8::ucfirst qq<';
5326 0           $left_e++;
5327             }
5328             elsif ($char[$i] eq '\l') {
5329 0           $char[$i] = '@{[Char::Elatin8::lcfirst qq<';
5330 0           $left_e++;
5331             }
5332             elsif ($char[$i] eq '\U') {
5333 0           $char[$i] = '@{[Char::Elatin8::uc qq<';
5334 0           $left_e++;
5335             }
5336             elsif ($char[$i] eq '\L') {
5337 0           $char[$i] = '@{[Char::Elatin8::lc qq<';
5338 0           $left_e++;
5339             }
5340             elsif ($char[$i] eq '\F') {
5341 0           $char[$i] = '@{[Char::Elatin8::fc qq<';
5342 0           $left_e++;
5343             }
5344             elsif ($char[$i] eq '\Q') {
5345 0           $char[$i] = '@{[CORE::quotemeta qq<';
5346 0           $left_e++;
5347             }
5348             elsif ($char[$i] eq '\E') {
5349 0 0         if ($right_e < $left_e) {
5350 0           $char[$i] = '>]}';
5351 0           $right_e++;
5352             }
5353             else {
5354 0           $char[$i] = '';
5355             }
5356             }
5357             elsif ($char[$i] eq '\Q') {
5358 0           while (1) {
5359 0 0         if (++$i > $#char) {
5360 0           last;
5361             }
5362 0 0         if ($char[$i] eq '\E') {
5363 0           last;
5364             }
5365             }
5366             }
5367             elsif ($char[$i] eq '\E') {
5368             }
5369              
5370             # $0 --> $0
5371             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5372             }
5373             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5374             }
5375              
5376             # $$ --> $$
5377             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5378             }
5379              
5380             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5381             # $1, $2, $3 --> $1, $2, $3 otherwise
5382             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5383 0           $char[$i] = e_capture($1);
5384             }
5385             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5386 0           $char[$i] = e_capture($1);
5387             }
5388              
5389             # $$foo[ ... ] --> $ $foo->[ ... ]
5390             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5391 0           $char[$i] = e_capture($1.'->'.$2);
5392             }
5393              
5394             # $$foo{ ... } --> $ $foo->{ ... }
5395             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5396 0           $char[$i] = e_capture($1.'->'.$2);
5397             }
5398              
5399             # $$foo
5400             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5401 0           $char[$i] = e_capture($1);
5402             }
5403              
5404             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin8::PREMATCH()
5405             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5406 0           $char[$i] = '@{[Char::Elatin8::PREMATCH()]}';
5407             }
5408              
5409             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin8::MATCH()
5410             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5411 0           $char[$i] = '@{[Char::Elatin8::MATCH()]}';
5412             }
5413              
5414             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin8::POSTMATCH()
5415             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5416 0           $char[$i] = '@{[Char::Elatin8::POSTMATCH()]}';
5417             }
5418              
5419             # ${ foo } --> ${ foo }
5420             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5421             }
5422              
5423             # ${ ... }
5424             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5425 0           $char[$i] = e_capture($1);
5426             }
5427             }
5428              
5429             # return string
5430 0 0         if ($left_e > $right_e) {
5431 0           return join '', @char, '>]}' x ($left_e - $right_e);
5432             }
5433 0           return join '', @char;
5434             }
5435              
5436             #
5437             # escape regexp (m//, qr//)
5438             #
5439             sub e_qr {
5440 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5441 0   0       $modifier ||= '';
5442              
5443 0           $modifier =~ tr/p//d;
5444 0 0         if ($modifier =~ /([adlu])/oxms) {
5445 0           my $line = 0;
5446 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5447 0 0         if ($filename ne __FILE__) {
5448 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5449 0           last;
5450             }
5451             }
5452 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5453             }
5454              
5455 0           $slash = 'div';
5456              
5457             # literal null string pattern
5458 0 0         if ($string eq '') {
    0          
5459 0           $modifier =~ tr/bB//d;
5460 0           $modifier =~ tr/i//d;
5461 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5462             }
5463              
5464             # /b /B modifier
5465             elsif ($modifier =~ tr/bB//d) {
5466              
5467             # choice again delimiter
5468 0 0         if ($delimiter =~ / [\@:] /oxms) {
5469 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5470 0           my %octet = map {$_ => 1} @char;
  0            
5471 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5472 0           $delimiter = '(';
5473 0           $end_delimiter = ')';
5474             }
5475             elsif (not $octet{'}'}) {
5476 0           $delimiter = '{';
5477 0           $end_delimiter = '}';
5478             }
5479             elsif (not $octet{']'}) {
5480 0           $delimiter = '[';
5481 0           $end_delimiter = ']';
5482             }
5483             elsif (not $octet{'>'}) {
5484 0           $delimiter = '<';
5485 0           $end_delimiter = '>';
5486             }
5487             else {
5488 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5489 0 0         if (not $octet{$char}) {
5490 0           $delimiter = $char;
5491 0           $end_delimiter = $char;
5492 0           last;
5493             }
5494             }
5495             }
5496             }
5497              
5498 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5499 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5500             }
5501             else {
5502 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5503             }
5504             }
5505              
5506 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5507 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5508              
5509             # split regexp
5510 0           my @char = $string =~ /\G(
5511             \\o\{ [0-7]+ \} |
5512             \\ [0-7]{2,3} |
5513             \\x\{ [0-9A-Fa-f]+ \} |
5514             \\x [0-9A-Fa-f]{1,2} |
5515             \\c [\x40-\x5F] |
5516             \\N\{ [^0-9\}][^\}]* \} |
5517             \\p\{ [^0-9\}][^\}]* \} |
5518             \\P\{ [^0-9\}][^\}]* \} |
5519             \\ (?:$q_char) |
5520             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5521             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5522             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5523             [\$\@] $qq_variable |
5524             \$ \s* \d+ |
5525             \$ \s* \{ \s* \d+ \s* \} |
5526             \$ \$ (?![\w\{]) |
5527             \$ \s* \$ \s* $qq_variable |
5528             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5529             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5530             \[\^ |
5531             \(\? |
5532             (?:$q_char)
5533             )/oxmsg;
5534              
5535             # choice again delimiter
5536 0 0         if ($delimiter =~ / [\@:] /oxms) {
5537 0           my %octet = map {$_ => 1} @char;
  0            
5538 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5539 0           $delimiter = '(';
5540 0           $end_delimiter = ')';
5541             }
5542             elsif (not $octet{'}'}) {
5543 0           $delimiter = '{';
5544 0           $end_delimiter = '}';
5545             }
5546             elsif (not $octet{']'}) {
5547 0           $delimiter = '[';
5548 0           $end_delimiter = ']';
5549             }
5550             elsif (not $octet{'>'}) {
5551 0           $delimiter = '<';
5552 0           $end_delimiter = '>';
5553             }
5554             else {
5555 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5556 0 0         if (not $octet{$char}) {
5557 0           $delimiter = $char;
5558 0           $end_delimiter = $char;
5559 0           last;
5560             }
5561             }
5562             }
5563             }
5564              
5565 0           my $left_e = 0;
5566 0           my $right_e = 0;
5567 0           for (my $i=0; $i <= $#char; $i++) {
5568              
5569             # "\L\u" --> "\u\L"
5570 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
5571 0           @char[$i,$i+1] = @char[$i+1,$i];
5572             }
5573              
5574             # "\U\l" --> "\l\U"
5575             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5576 0           @char[$i,$i+1] = @char[$i+1,$i];
5577             }
5578              
5579             # octal escape sequence
5580             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5581 0           $char[$i] = Char::Elatin8::octchr($1);
5582             }
5583              
5584             # hexadecimal escape sequence
5585             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5586 0           $char[$i] = Char::Elatin8::hexchr($1);
5587             }
5588              
5589             # \N{CHARNAME} --> N\{CHARNAME}
5590             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5591 0           $char[$i] = $1 . '\\' . $2;
5592             }
5593              
5594             # \p{PROPERTY} --> p\{PROPERTY}
5595             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5596 0           $char[$i] = $1 . '\\' . $2;
5597             }
5598              
5599             # \P{PROPERTY} --> P\{PROPERTY}
5600             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5601 0           $char[$i] = $1 . '\\' . $2;
5602             }
5603              
5604             # \p, \P, \X --> p, P, X
5605             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5606 0           $char[$i] = $1;
5607             }
5608              
5609 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5610             }
5611              
5612             # join separated multiple-octet
5613 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5614 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        
5615 0           $char[$i] .= join '', splice @char, $i+1, 3;
5616             }
5617             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)) {
5618 0           $char[$i] .= join '', splice @char, $i+1, 2;
5619             }
5620             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)) {
5621 0           $char[$i] .= join '', splice @char, $i+1, 1;
5622             }
5623             }
5624              
5625             # open character class [...]
5626             elsif ($char[$i] eq '[') {
5627 0           my $left = $i;
5628              
5629             # [] make die "Unmatched [] in regexp ..."
5630             # (and so on)
5631              
5632 0 0         if ($char[$i+1] eq ']') {
5633 0           $i++;
5634             }
5635              
5636 0           while (1) {
5637 0 0         if (++$i > $#char) {
5638 0           die __FILE__, ": Unmatched [] in regexp";
5639             }
5640 0 0         if ($char[$i] eq ']') {
5641 0           my $right = $i;
5642              
5643             # [...]
5644 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5645 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5646             }
5647             else {
5648 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
5649             }
5650              
5651 0           $i = $left;
5652 0           last;
5653             }
5654             }
5655             }
5656              
5657             # open character class [^...]
5658             elsif ($char[$i] eq '[^') {
5659 0           my $left = $i;
5660              
5661             # [^] make die "Unmatched [] in regexp ..."
5662             # (and so on)
5663              
5664 0 0         if ($char[$i+1] eq ']') {
5665 0           $i++;
5666             }
5667              
5668 0           while (1) {
5669 0 0         if (++$i > $#char) {
5670 0           die __FILE__, ": Unmatched [] in regexp";
5671             }
5672 0 0         if ($char[$i] eq ']') {
5673 0           my $right = $i;
5674              
5675             # [^...]
5676 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5677 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5678             }
5679             else {
5680 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5681             }
5682              
5683 0           $i = $left;
5684 0           last;
5685             }
5686             }
5687             }
5688              
5689             # rewrite character class or escape character
5690             elsif (my $char = character_class($char[$i],$modifier)) {
5691 0           $char[$i] = $char;
5692             }
5693              
5694             # /i modifier
5695             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin8::uc($char[$i]) ne Char::Elatin8::fc($char[$i]))) {
5696 0 0         if (CORE::length(Char::Elatin8::fc($char[$i])) == 1) {
5697 0           $char[$i] = '[' . Char::Elatin8::uc($char[$i]) . Char::Elatin8::fc($char[$i]) . ']';
5698             }
5699             else {
5700 0           $char[$i] = '(?:' . Char::Elatin8::uc($char[$i]) . '|' . Char::Elatin8::fc($char[$i]) . ')';
5701             }
5702             }
5703              
5704             # \u \l \U \L \F \Q \E
5705             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5706 0 0         if ($right_e < $left_e) {
5707 0           $char[$i] = '\\' . $char[$i];
5708             }
5709             }
5710             elsif ($char[$i] eq '\u') {
5711 0           $char[$i] = '@{[Char::Elatin8::ucfirst qq<';
5712 0           $left_e++;
5713             }
5714             elsif ($char[$i] eq '\l') {
5715 0           $char[$i] = '@{[Char::Elatin8::lcfirst qq<';
5716 0           $left_e++;
5717             }
5718             elsif ($char[$i] eq '\U') {
5719 0           $char[$i] = '@{[Char::Elatin8::uc qq<';
5720 0           $left_e++;
5721             }
5722             elsif ($char[$i] eq '\L') {
5723 0           $char[$i] = '@{[Char::Elatin8::lc qq<';
5724 0           $left_e++;
5725             }
5726             elsif ($char[$i] eq '\F') {
5727 0           $char[$i] = '@{[Char::Elatin8::fc qq<';
5728 0           $left_e++;
5729             }
5730             elsif ($char[$i] eq '\Q') {
5731 0           $char[$i] = '@{[CORE::quotemeta qq<';
5732 0           $left_e++;
5733             }
5734             elsif ($char[$i] eq '\E') {
5735 0 0         if ($right_e < $left_e) {
5736 0           $char[$i] = '>]}';
5737 0           $right_e++;
5738             }
5739             else {
5740 0           $char[$i] = '';
5741             }
5742             }
5743             elsif ($char[$i] eq '\Q') {
5744 0           while (1) {
5745 0 0         if (++$i > $#char) {
5746 0           last;
5747             }
5748 0 0         if ($char[$i] eq '\E') {
5749 0           last;
5750             }
5751             }
5752             }
5753             elsif ($char[$i] eq '\E') {
5754             }
5755              
5756             # $0 --> $0
5757             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5758 0 0         if ($ignorecase) {
5759 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5760             }
5761             }
5762             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5763 0 0         if ($ignorecase) {
5764 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5765             }
5766             }
5767              
5768             # $$ --> $$
5769             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5770             }
5771              
5772             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5773             # $1, $2, $3 --> $1, $2, $3 otherwise
5774             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5775 0           $char[$i] = e_capture($1);
5776 0 0         if ($ignorecase) {
5777 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5778             }
5779             }
5780             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5781 0           $char[$i] = e_capture($1);
5782 0 0         if ($ignorecase) {
5783 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5784             }
5785             }
5786              
5787             # $$foo[ ... ] --> $ $foo->[ ... ]
5788             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5789 0           $char[$i] = e_capture($1.'->'.$2);
5790 0 0         if ($ignorecase) {
5791 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5792             }
5793             }
5794              
5795             # $$foo{ ... } --> $ $foo->{ ... }
5796             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5797 0           $char[$i] = e_capture($1.'->'.$2);
5798 0 0         if ($ignorecase) {
5799 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5800             }
5801             }
5802              
5803             # $$foo
5804             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5805 0           $char[$i] = e_capture($1);
5806 0 0         if ($ignorecase) {
5807 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5808             }
5809             }
5810              
5811             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin8::PREMATCH()
5812             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5813 0 0         if ($ignorecase) {
5814 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::PREMATCH())]}';
5815             }
5816             else {
5817 0           $char[$i] = '@{[Char::Elatin8::PREMATCH()]}';
5818             }
5819             }
5820              
5821             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin8::MATCH()
5822             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5823 0 0         if ($ignorecase) {
5824 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::MATCH())]}';
5825             }
5826             else {
5827 0           $char[$i] = '@{[Char::Elatin8::MATCH()]}';
5828             }
5829             }
5830              
5831             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin8::POSTMATCH()
5832             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5833 0 0         if ($ignorecase) {
5834 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::POSTMATCH())]}';
5835             }
5836             else {
5837 0           $char[$i] = '@{[Char::Elatin8::POSTMATCH()]}';
5838             }
5839             }
5840              
5841             # ${ foo }
5842             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5843 0 0         if ($ignorecase) {
5844 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5845             }
5846             }
5847              
5848             # ${ ... }
5849             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5850 0           $char[$i] = e_capture($1);
5851 0 0         if ($ignorecase) {
5852 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5853             }
5854             }
5855              
5856             # $scalar or @array
5857             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5858 0           $char[$i] = e_string($char[$i]);
5859 0 0         if ($ignorecase) {
5860 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
5861             }
5862             }
5863              
5864             # quote character before ? + * {
5865             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5866 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5867             }
5868             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5869 0           my $char = $char[$i-1];
5870 0 0         if ($char[$i] eq '{') {
5871 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
5872             }
5873             else {
5874 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
5875             }
5876             }
5877             else {
5878 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5879             }
5880             }
5881             }
5882              
5883             # make regexp string
5884 0           $modifier =~ tr/i//d;
5885 0 0         if ($left_e > $right_e) {
5886 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5887 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5888             }
5889             else {
5890 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5891             }
5892             }
5893 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5894 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5895             }
5896             else {
5897 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5898             }
5899             }
5900              
5901             #
5902             # double quote stuff
5903             #
5904             sub qq_stuff {
5905 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5906              
5907             # scalar variable or array variable
5908 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5909 0           return $stuff;
5910             }
5911              
5912             # quote by delimiter
5913 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5914 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5915 0 0         next if $char eq $delimiter;
5916 0 0         next if $char eq $end_delimiter;
5917 0 0         if (not $octet{$char}) {
5918 0           return join '', 'qq', $char, $stuff, $char;
5919             }
5920             }
5921 0           return join '', 'qq', '<', $stuff, '>';
5922             }
5923              
5924             #
5925             # escape regexp (m'', qr'', and m''b, qr''b)
5926             #
5927             sub e_qr_q {
5928 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5929 0   0       $modifier ||= '';
5930              
5931 0           $modifier =~ tr/p//d;
5932 0 0         if ($modifier =~ /([adlu])/oxms) {
5933 0           my $line = 0;
5934 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5935 0 0         if ($filename ne __FILE__) {
5936 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5937 0           last;
5938             }
5939             }
5940 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5941             }
5942              
5943 0           $slash = 'div';
5944              
5945             # literal null string pattern
5946 0 0         if ($string eq '') {
    0          
5947 0           $modifier =~ tr/bB//d;
5948 0           $modifier =~ tr/i//d;
5949 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5950             }
5951              
5952             # with /b /B modifier
5953             elsif ($modifier =~ tr/bB//d) {
5954 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5955             }
5956              
5957             # without /b /B modifier
5958             else {
5959 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5960             }
5961             }
5962              
5963             #
5964             # escape regexp (m'', qr'')
5965             #
5966             sub e_qr_qt {
5967 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5968              
5969 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5970              
5971             # split regexp
5972 0           my @char = $string =~ /\G(
5973             \[\:\^ [a-z]+ \:\] |
5974             \[\: [a-z]+ \:\] |
5975             \[\^ |
5976             [\$\@\/\\] |
5977             \\? (?:$q_char)
5978             )/oxmsg;
5979              
5980             # unescape character
5981 0           for (my $i=0; $i <= $#char; $i++) {
5982 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5983             }
5984              
5985             # open character class [...]
5986 0           elsif ($char[$i] eq '[') {
5987 0           my $left = $i;
5988 0 0         if ($char[$i+1] eq ']') {
5989 0           $i++;
5990             }
5991 0           while (1) {
5992 0 0         if (++$i > $#char) {
5993 0           die __FILE__, ": Unmatched [] in regexp";
5994             }
5995 0 0         if ($char[$i] eq ']') {
5996 0           my $right = $i;
5997              
5998             # [...]
5999 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6000              
6001 0           $i = $left;
6002 0           last;
6003             }
6004             }
6005             }
6006              
6007             # open character class [^...]
6008             elsif ($char[$i] eq '[^') {
6009 0           my $left = $i;
6010 0 0         if ($char[$i+1] eq ']') {
6011 0           $i++;
6012             }
6013 0           while (1) {
6014 0 0         if (++$i > $#char) {
6015 0           die __FILE__, ": Unmatched [] in regexp";
6016             }
6017 0 0         if ($char[$i] eq ']') {
6018 0           my $right = $i;
6019              
6020             # [^...]
6021 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6022              
6023 0           $i = $left;
6024 0           last;
6025             }
6026             }
6027             }
6028              
6029             # escape $ @ / and \
6030             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6031 0           $char[$i] = '\\' . $char[$i];
6032             }
6033              
6034             # rewrite character class or escape character
6035             elsif (my $char = character_class($char[$i],$modifier)) {
6036 0           $char[$i] = $char;
6037             }
6038              
6039             # /i modifier
6040             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin8::uc($char[$i]) ne Char::Elatin8::fc($char[$i]))) {
6041 0 0         if (CORE::length(Char::Elatin8::fc($char[$i])) == 1) {
6042 0           $char[$i] = '[' . Char::Elatin8::uc($char[$i]) . Char::Elatin8::fc($char[$i]) . ']';
6043             }
6044             else {
6045 0           $char[$i] = '(?:' . Char::Elatin8::uc($char[$i]) . '|' . Char::Elatin8::fc($char[$i]) . ')';
6046             }
6047             }
6048              
6049             # quote character before ? + * {
6050             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6051 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6052             }
6053             else {
6054 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6055             }
6056             }
6057             }
6058              
6059 0           $delimiter = '/';
6060 0           $end_delimiter = '/';
6061              
6062 0           $modifier =~ tr/i//d;
6063 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6064             }
6065              
6066             #
6067             # escape regexp (m''b, qr''b)
6068             #
6069             sub e_qr_qb {
6070 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6071              
6072             # split regexp
6073 0           my @char = $string =~ /\G(
6074             \\\\ |
6075             [\$\@\/\\] |
6076             [\x00-\xFF]
6077             )/oxmsg;
6078              
6079             # unescape character
6080 0           for (my $i=0; $i <= $#char; $i++) {
6081 0 0         if (0) {
    0          
6082             }
6083              
6084             # remain \\
6085 0           elsif ($char[$i] eq '\\\\') {
6086             }
6087              
6088             # escape $ @ / and \
6089             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6090 0           $char[$i] = '\\' . $char[$i];
6091             }
6092             }
6093              
6094 0           $delimiter = '/';
6095 0           $end_delimiter = '/';
6096 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6097             }
6098              
6099             #
6100             # escape regexp (s/here//)
6101             #
6102             sub e_s1 {
6103 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6104 0   0       $modifier ||= '';
6105              
6106 0           $modifier =~ tr/p//d;
6107 0 0         if ($modifier =~ /([adlu])/oxms) {
6108 0           my $line = 0;
6109 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6110 0 0         if ($filename ne __FILE__) {
6111 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6112 0           last;
6113             }
6114             }
6115 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6116             }
6117              
6118 0           $slash = 'div';
6119              
6120             # literal null string pattern
6121 0 0         if ($string eq '') {
    0          
6122 0           $modifier =~ tr/bB//d;
6123 0           $modifier =~ tr/i//d;
6124 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6125             }
6126              
6127             # /b /B modifier
6128             elsif ($modifier =~ tr/bB//d) {
6129              
6130             # choice again delimiter
6131 0 0         if ($delimiter =~ / [\@:] /oxms) {
6132 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
6133 0           my %octet = map {$_ => 1} @char;
  0            
6134 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6135 0           $delimiter = '(';
6136 0           $end_delimiter = ')';
6137             }
6138             elsif (not $octet{'}'}) {
6139 0           $delimiter = '{';
6140 0           $end_delimiter = '}';
6141             }
6142             elsif (not $octet{']'}) {
6143 0           $delimiter = '[';
6144 0           $end_delimiter = ']';
6145             }
6146             elsif (not $octet{'>'}) {
6147 0           $delimiter = '<';
6148 0           $end_delimiter = '>';
6149             }
6150             else {
6151 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6152 0 0         if (not $octet{$char}) {
6153 0           $delimiter = $char;
6154 0           $end_delimiter = $char;
6155 0           last;
6156             }
6157             }
6158             }
6159             }
6160              
6161 0           my $prematch = '';
6162 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6163             }
6164              
6165 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6166 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6167              
6168             # split regexp
6169 0           my @char = $string =~ /\G(
6170             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
6171             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
6172             \\g \s* [1-9][0-9]* |
6173             \\o\{ [0-7]+ \} |
6174             \\ [1-9][0-9]* |
6175             \\ [0-7]{2,3} |
6176             \\x\{ [0-9A-Fa-f]+ \} |
6177             \\x [0-9A-Fa-f]{1,2} |
6178             \\c [\x40-\x5F] |
6179             \\N\{ [^0-9\}][^\}]* \} |
6180             \\p\{ [^0-9\}][^\}]* \} |
6181             \\P\{ [^0-9\}][^\}]* \} |
6182             \\ (?:$q_char) |
6183             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6184             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6185             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6186             [\$\@] $qq_variable |
6187             \$ \s* \d+ |
6188             \$ \s* \{ \s* \d+ \s* \} |
6189             \$ \$ (?![\w\{]) |
6190             \$ \s* \$ \s* $qq_variable |
6191             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6192             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6193             \[\^ |
6194             \(\? |
6195             (?:$q_char)
6196             )/oxmsg;
6197              
6198             # choice again delimiter
6199 0 0         if ($delimiter =~ / [\@:] /oxms) {
6200 0           my %octet = map {$_ => 1} @char;
  0            
6201 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6202 0           $delimiter = '(';
6203 0           $end_delimiter = ')';
6204             }
6205             elsif (not $octet{'}'}) {
6206 0           $delimiter = '{';
6207 0           $end_delimiter = '}';
6208             }
6209             elsif (not $octet{']'}) {
6210 0           $delimiter = '[';
6211 0           $end_delimiter = ']';
6212             }
6213             elsif (not $octet{'>'}) {
6214 0           $delimiter = '<';
6215 0           $end_delimiter = '>';
6216             }
6217             else {
6218 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6219 0 0         if (not $octet{$char}) {
6220 0           $delimiter = $char;
6221 0           $end_delimiter = $char;
6222 0           last;
6223             }
6224             }
6225             }
6226             }
6227              
6228             # count '('
6229 0           my $parens = grep { $_ eq '(' } @char;
  0            
6230              
6231 0           my $left_e = 0;
6232 0           my $right_e = 0;
6233 0           for (my $i=0; $i <= $#char; $i++) {
6234              
6235             # "\L\u" --> "\u\L"
6236 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6237 0           @char[$i,$i+1] = @char[$i+1,$i];
6238             }
6239              
6240             # "\U\l" --> "\l\U"
6241             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6242 0           @char[$i,$i+1] = @char[$i+1,$i];
6243             }
6244              
6245             # octal escape sequence
6246             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6247 0           $char[$i] = Char::Elatin8::octchr($1);
6248             }
6249              
6250             # hexadecimal escape sequence
6251             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6252 0           $char[$i] = Char::Elatin8::hexchr($1);
6253             }
6254              
6255             # \N{CHARNAME} --> N\{CHARNAME}
6256             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6257 0           $char[$i] = $1 . '\\' . $2;
6258             }
6259              
6260             # \p{PROPERTY} --> p\{PROPERTY}
6261             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6262 0           $char[$i] = $1 . '\\' . $2;
6263             }
6264              
6265             # \P{PROPERTY} --> P\{PROPERTY}
6266             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6267 0           $char[$i] = $1 . '\\' . $2;
6268             }
6269              
6270             # \p, \P, \X --> p, P, X
6271             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6272 0           $char[$i] = $1;
6273             }
6274              
6275 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6276             }
6277              
6278             # join separated multiple-octet
6279 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6280 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        
6281 0           $char[$i] .= join '', splice @char, $i+1, 3;
6282             }
6283             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)) {
6284 0           $char[$i] .= join '', splice @char, $i+1, 2;
6285             }
6286             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)) {
6287 0           $char[$i] .= join '', splice @char, $i+1, 1;
6288             }
6289             }
6290              
6291             # open character class [...]
6292             elsif ($char[$i] eq '[') {
6293 0           my $left = $i;
6294 0 0         if ($char[$i+1] eq ']') {
6295 0           $i++;
6296             }
6297 0           while (1) {
6298 0 0         if (++$i > $#char) {
6299 0           die __FILE__, ": Unmatched [] in regexp";
6300             }
6301 0 0         if ($char[$i] eq ']') {
6302 0           my $right = $i;
6303              
6304             # [...]
6305 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6306 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6307             }
6308             else {
6309 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6310             }
6311              
6312 0           $i = $left;
6313 0           last;
6314             }
6315             }
6316             }
6317              
6318             # open character class [^...]
6319             elsif ($char[$i] eq '[^') {
6320 0           my $left = $i;
6321 0 0         if ($char[$i+1] eq ']') {
6322 0           $i++;
6323             }
6324 0           while (1) {
6325 0 0         if (++$i > $#char) {
6326 0           die __FILE__, ": Unmatched [] in regexp";
6327             }
6328 0 0         if ($char[$i] eq ']') {
6329 0           my $right = $i;
6330              
6331             # [^...]
6332 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6333 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6334             }
6335             else {
6336 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6337             }
6338              
6339 0           $i = $left;
6340 0           last;
6341             }
6342             }
6343             }
6344              
6345             # rewrite character class or escape character
6346             elsif (my $char = character_class($char[$i],$modifier)) {
6347 0           $char[$i] = $char;
6348             }
6349              
6350             # /i modifier
6351             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin8::uc($char[$i]) ne Char::Elatin8::fc($char[$i]))) {
6352 0 0         if (CORE::length(Char::Elatin8::fc($char[$i])) == 1) {
6353 0           $char[$i] = '[' . Char::Elatin8::uc($char[$i]) . Char::Elatin8::fc($char[$i]) . ']';
6354             }
6355             else {
6356 0           $char[$i] = '(?:' . Char::Elatin8::uc($char[$i]) . '|' . Char::Elatin8::fc($char[$i]) . ')';
6357             }
6358             }
6359              
6360             # \u \l \U \L \F \Q \E
6361             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6362 0 0         if ($right_e < $left_e) {
6363 0           $char[$i] = '\\' . $char[$i];
6364             }
6365             }
6366             elsif ($char[$i] eq '\u') {
6367 0           $char[$i] = '@{[Char::Elatin8::ucfirst qq<';
6368 0           $left_e++;
6369             }
6370             elsif ($char[$i] eq '\l') {
6371 0           $char[$i] = '@{[Char::Elatin8::lcfirst qq<';
6372 0           $left_e++;
6373             }
6374             elsif ($char[$i] eq '\U') {
6375 0           $char[$i] = '@{[Char::Elatin8::uc qq<';
6376 0           $left_e++;
6377             }
6378             elsif ($char[$i] eq '\L') {
6379 0           $char[$i] = '@{[Char::Elatin8::lc qq<';
6380 0           $left_e++;
6381             }
6382             elsif ($char[$i] eq '\F') {
6383 0           $char[$i] = '@{[Char::Elatin8::fc qq<';
6384 0           $left_e++;
6385             }
6386             elsif ($char[$i] eq '\Q') {
6387 0           $char[$i] = '@{[CORE::quotemeta qq<';
6388 0           $left_e++;
6389             }
6390             elsif ($char[$i] eq '\E') {
6391 0 0         if ($right_e < $left_e) {
6392 0           $char[$i] = '>]}';
6393 0           $right_e++;
6394             }
6395             else {
6396 0           $char[$i] = '';
6397             }
6398             }
6399             elsif ($char[$i] eq '\Q') {
6400 0           while (1) {
6401 0 0         if (++$i > $#char) {
6402 0           last;
6403             }
6404 0 0         if ($char[$i] eq '\E') {
6405 0           last;
6406             }
6407             }
6408             }
6409             elsif ($char[$i] eq '\E') {
6410             }
6411              
6412             # \0 --> \0
6413             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
6414             }
6415              
6416             # \g{N}, \g{-N}
6417              
6418             # P.108 Using Simple Patterns
6419             # in Chapter 7: In the World of Regular Expressions
6420             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6421              
6422             # P.221 Capturing
6423             # in Chapter 5: Pattern Matching
6424             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6425              
6426             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6427             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6428             }
6429              
6430             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6431             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6432             }
6433              
6434             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6435             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
6436             }
6437              
6438             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6439             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
6440             }
6441              
6442             # $0 --> $0
6443             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6444 0 0         if ($ignorecase) {
6445 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6446             }
6447             }
6448             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
6449 0 0         if ($ignorecase) {
6450 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6451             }
6452             }
6453              
6454             # $$ --> $$
6455             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6456             }
6457              
6458             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6459             # $1, $2, $3 --> $1, $2, $3 otherwise
6460             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
6461 0           $char[$i] = e_capture($1);
6462 0 0         if ($ignorecase) {
6463 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6464             }
6465             }
6466             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6467 0           $char[$i] = e_capture($1);
6468 0 0         if ($ignorecase) {
6469 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6470             }
6471             }
6472              
6473             # $$foo[ ... ] --> $ $foo->[ ... ]
6474             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6475 0           $char[$i] = e_capture($1.'->'.$2);
6476 0 0         if ($ignorecase) {
6477 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6478             }
6479             }
6480              
6481             # $$foo{ ... } --> $ $foo->{ ... }
6482             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6483 0           $char[$i] = e_capture($1.'->'.$2);
6484 0 0         if ($ignorecase) {
6485 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6486             }
6487             }
6488              
6489             # $$foo
6490             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
6491 0           $char[$i] = e_capture($1);
6492 0 0         if ($ignorecase) {
6493 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6494             }
6495             }
6496              
6497             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin8::PREMATCH()
6498             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
6499 0 0         if ($ignorecase) {
6500 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::PREMATCH())]}';
6501             }
6502             else {
6503 0           $char[$i] = '@{[Char::Elatin8::PREMATCH()]}';
6504             }
6505             }
6506              
6507             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin8::MATCH()
6508             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
6509 0 0         if ($ignorecase) {
6510 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::MATCH())]}';
6511             }
6512             else {
6513 0           $char[$i] = '@{[Char::Elatin8::MATCH()]}';
6514             }
6515             }
6516              
6517             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin8::POSTMATCH()
6518             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
6519 0 0         if ($ignorecase) {
6520 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::POSTMATCH())]}';
6521             }
6522             else {
6523 0           $char[$i] = '@{[Char::Elatin8::POSTMATCH()]}';
6524             }
6525             }
6526              
6527             # ${ foo }
6528             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
6529 0 0         if ($ignorecase) {
6530 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6531             }
6532             }
6533              
6534             # ${ ... }
6535             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
6536 0           $char[$i] = e_capture($1);
6537 0 0         if ($ignorecase) {
6538 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6539             }
6540             }
6541              
6542             # $scalar or @array
6543             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6544 0           $char[$i] = e_string($char[$i]);
6545 0 0         if ($ignorecase) {
6546 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
6547             }
6548             }
6549              
6550             # quote character before ? + * {
6551             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6552 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6553             }
6554             else {
6555 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6556             }
6557             }
6558             }
6559              
6560             # make regexp string
6561 0           my $prematch = '';
6562 0           $modifier =~ tr/i//d;
6563 0 0         if ($left_e > $right_e) {
6564 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6565             }
6566 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6567             }
6568              
6569             #
6570             # escape regexp (s'here'' or s'here''b)
6571             #
6572             sub e_s1_q {
6573 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6574 0   0       $modifier ||= '';
6575              
6576 0           $modifier =~ tr/p//d;
6577 0 0         if ($modifier =~ /([adlu])/oxms) {
6578 0           my $line = 0;
6579 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6580 0 0         if ($filename ne __FILE__) {
6581 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6582 0           last;
6583             }
6584             }
6585 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6586             }
6587              
6588 0           $slash = 'div';
6589              
6590             # literal null string pattern
6591 0 0         if ($string eq '') {
    0          
6592 0           $modifier =~ tr/bB//d;
6593 0           $modifier =~ tr/i//d;
6594 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6595             }
6596              
6597             # with /b /B modifier
6598             elsif ($modifier =~ tr/bB//d) {
6599 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6600             }
6601              
6602             # without /b /B modifier
6603             else {
6604 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6605             }
6606             }
6607              
6608             #
6609             # escape regexp (s'here'')
6610             #
6611             sub e_s1_qt {
6612 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6613              
6614 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6615              
6616             # split regexp
6617 0           my @char = $string =~ /\G(
6618             \[\:\^ [a-z]+ \:\] |
6619             \[\: [a-z]+ \:\] |
6620             \[\^ |
6621             [\$\@\/\\] |
6622             \\? (?:$q_char)
6623             )/oxmsg;
6624              
6625             # unescape character
6626 0           for (my $i=0; $i <= $#char; $i++) {
6627 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6628             }
6629              
6630             # open character class [...]
6631 0           elsif ($char[$i] eq '[') {
6632 0           my $left = $i;
6633 0 0         if ($char[$i+1] eq ']') {
6634 0           $i++;
6635             }
6636 0           while (1) {
6637 0 0         if (++$i > $#char) {
6638 0           die __FILE__, ": Unmatched [] in regexp";
6639             }
6640 0 0         if ($char[$i] eq ']') {
6641 0           my $right = $i;
6642              
6643             # [...]
6644 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6645              
6646 0           $i = $left;
6647 0           last;
6648             }
6649             }
6650             }
6651              
6652             # open character class [^...]
6653             elsif ($char[$i] eq '[^') {
6654 0           my $left = $i;
6655 0 0         if ($char[$i+1] eq ']') {
6656 0           $i++;
6657             }
6658 0           while (1) {
6659 0 0         if (++$i > $#char) {
6660 0           die __FILE__, ": Unmatched [] in regexp";
6661             }
6662 0 0         if ($char[$i] eq ']') {
6663 0           my $right = $i;
6664              
6665             # [^...]
6666 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6667              
6668 0           $i = $left;
6669 0           last;
6670             }
6671             }
6672             }
6673              
6674             # escape $ @ / and \
6675             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6676 0           $char[$i] = '\\' . $char[$i];
6677             }
6678              
6679             # rewrite character class or escape character
6680             elsif (my $char = character_class($char[$i],$modifier)) {
6681 0           $char[$i] = $char;
6682             }
6683              
6684             # /i modifier
6685             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin8::uc($char[$i]) ne Char::Elatin8::fc($char[$i]))) {
6686 0 0         if (CORE::length(Char::Elatin8::fc($char[$i])) == 1) {
6687 0           $char[$i] = '[' . Char::Elatin8::uc($char[$i]) . Char::Elatin8::fc($char[$i]) . ']';
6688             }
6689             else {
6690 0           $char[$i] = '(?:' . Char::Elatin8::uc($char[$i]) . '|' . Char::Elatin8::fc($char[$i]) . ')';
6691             }
6692             }
6693              
6694             # quote character before ? + * {
6695             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6696 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6697             }
6698             else {
6699 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6700             }
6701             }
6702             }
6703              
6704 0           $modifier =~ tr/i//d;
6705 0           $delimiter = '/';
6706 0           $end_delimiter = '/';
6707 0           my $prematch = '';
6708 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6709             }
6710              
6711             #
6712             # escape regexp (s'here''b)
6713             #
6714             sub e_s1_qb {
6715 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6716              
6717             # split regexp
6718 0           my @char = $string =~ /\G(
6719             \\\\ |
6720             [\$\@\/\\] |
6721             [\x00-\xFF]
6722             )/oxmsg;
6723              
6724             # unescape character
6725 0           for (my $i=0; $i <= $#char; $i++) {
6726 0 0         if (0) {
    0          
6727             }
6728              
6729             # remain \\
6730 0           elsif ($char[$i] eq '\\\\') {
6731             }
6732              
6733             # escape $ @ / and \
6734             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6735 0           $char[$i] = '\\' . $char[$i];
6736             }
6737             }
6738              
6739 0           $delimiter = '/';
6740 0           $end_delimiter = '/';
6741 0           my $prematch = '';
6742 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6743             }
6744              
6745             #
6746             # escape regexp (s''here')
6747             #
6748             sub e_s2_q {
6749 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6750              
6751 0           $slash = 'div';
6752              
6753 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
6754 0           for (my $i=0; $i <= $#char; $i++) {
6755 0 0         if (0) {
    0          
6756             }
6757              
6758             # not escape \\
6759 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6760             }
6761              
6762             # escape $ @ / and \
6763             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6764 0           $char[$i] = '\\' . $char[$i];
6765             }
6766             }
6767              
6768 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6769             }
6770              
6771             #
6772             # escape regexp (s/here/and here/modifier)
6773             #
6774             sub e_sub {
6775 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6776 0   0       $modifier ||= '';
6777              
6778 0           $modifier =~ tr/p//d;
6779 0 0         if ($modifier =~ /([adlu])/oxms) {
6780 0           my $line = 0;
6781 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6782 0 0         if ($filename ne __FILE__) {
6783 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6784 0           last;
6785             }
6786             }
6787 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6788             }
6789              
6790 0 0         if ($variable eq '') {
6791 0           $variable = '$_';
6792 0           $bind_operator = ' =~ ';
6793             }
6794              
6795 0           $slash = 'div';
6796              
6797             # P.128 Start of match (or end of previous match): \G
6798             # P.130 Advanced Use of \G with Perl
6799             # in Chapter 3: Overview of Regular Expression Features and Flavors
6800             # P.312 Iterative Matching: Scalar Context, with /g
6801             # in Chapter 7: Perl
6802             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6803              
6804             # P.181 Where You Left Off: The \G Assertion
6805             # in Chapter 5: Pattern Matching
6806             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6807              
6808             # P.220 Where You Left Off: The \G Assertion
6809             # in Chapter 5: Pattern Matching
6810             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6811              
6812 0           my $e_modifier = $modifier =~ tr/e//d;
6813 0           my $r_modifier = $modifier =~ tr/r//d;
6814              
6815 0           my $my = '';
6816 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
6817 0           $my = $variable;
6818 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
6819 0           $variable =~ s/ = .+ \z//oxms;
6820             }
6821              
6822 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6823 0           $variable_basename =~ s/ \s+ \z//oxms;
6824              
6825             # quote replacement string
6826 0           my $e_replacement = '';
6827 0 0         if ($e_modifier >= 1) {
6828 0           $e_replacement = e_qq('', '', '', $replacement);
6829 0           $e_modifier--;
6830             }
6831             else {
6832 0 0         if ($delimiter2 eq "'") {
6833 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6834             }
6835             else {
6836 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6837             }
6838             }
6839              
6840 0           my $sub = '';
6841              
6842             # with /r
6843 0 0         if ($r_modifier) {
6844 0 0         if (0) {
6845             }
6846              
6847             # s///gr without multibyte anchoring
6848 0           elsif ($modifier =~ /g/oxms) {
6849 0 0         $sub = sprintf(
6850             # 1 2 3 4 5
6851             q,
6852              
6853             $variable, # 1
6854             ($delimiter1 eq "'") ? # 2
6855             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6856             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6857             $s_matched, # 3
6858             $e_replacement, # 4
6859             '$Char::Latin8::re_r=CORE::eval $Char::Latin8::re_r; ' x $e_modifier, # 5
6860             );
6861             }
6862              
6863             # s///r
6864             else {
6865              
6866 0           my $prematch = q{$`};
6867              
6868 0 0         $sub = sprintf(
6869             # 1 2 3 4 5 6 7
6870             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Char::Latin8::re_r=%s; %s"%s$Char::Latin8::re_r$'" } : %s>,
6871              
6872             $variable, # 1
6873             ($delimiter1 eq "'") ? # 2
6874             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6875             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6876             $s_matched, # 3
6877             $e_replacement, # 4
6878             '$Char::Latin8::re_r=CORE::eval $Char::Latin8::re_r; ' x $e_modifier, # 5
6879             $prematch, # 6
6880             $variable, # 7
6881             );
6882             }
6883              
6884             # $var !~ s///r doesn't make sense
6885 0 0         if ($bind_operator =~ / !~ /oxms) {
6886 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6887             }
6888             }
6889              
6890             # without /r
6891             else {
6892 0 0         if (0) {
6893             }
6894              
6895             # s///g without multibyte anchoring
6896 0           elsif ($modifier =~ /g/oxms) {
6897 0 0         $sub = sprintf(
    0          
6898             # 1 2 3 4 5 6 7 8
6899             q,
6900              
6901             $variable, # 1
6902             ($delimiter1 eq "'") ? # 2
6903             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6904             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6905             $s_matched, # 3
6906             $e_replacement, # 4
6907             '$Char::Latin8::re_r=CORE::eval $Char::Latin8::re_r; ' x $e_modifier, # 5
6908             $variable, # 6
6909             $variable, # 7
6910             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6911             );
6912             }
6913              
6914             # s///
6915             else {
6916              
6917 0           my $prematch = q{$`};
6918              
6919 0 0         $sub = sprintf(
    0          
6920              
6921             ($bind_operator =~ / =~ /oxms) ?
6922              
6923             # 1 2 3 4 5 6 7 8
6924             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Char::Latin8::re_r=%s; %s%s="%s$Char::Latin8::re_r$'"; 1 } : undef> :
6925              
6926             # 1 2 3 4 5 6 7 8
6927             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Char::Latin8::re_r=%s; %s%s="%s$Char::Latin8::re_r$'"; undef }>,
6928              
6929             $variable, # 1
6930             $bind_operator, # 2
6931             ($delimiter1 eq "'") ? # 3
6932             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6933             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6934             $s_matched, # 4
6935             $e_replacement, # 5
6936             '$Char::Latin8::re_r=CORE::eval $Char::Latin8::re_r; ' x $e_modifier, # 6
6937             $variable, # 7
6938             $prematch, # 8
6939             );
6940             }
6941             }
6942              
6943             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6944 0 0         if ($my ne '') {
6945 0           $sub = "($my, $sub)[1]";
6946             }
6947              
6948             # clear s/// variable
6949 0           $sub_variable = '';
6950 0           $bind_operator = '';
6951              
6952 0           return $sub;
6953             }
6954              
6955             #
6956             # escape regexp of split qr//
6957             #
6958             sub e_split {
6959 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6960 0   0       $modifier ||= '';
6961              
6962 0           $modifier =~ tr/p//d;
6963 0 0         if ($modifier =~ /([adlu])/oxms) {
6964 0           my $line = 0;
6965 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6966 0 0         if ($filename ne __FILE__) {
6967 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6968 0           last;
6969             }
6970             }
6971 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6972             }
6973              
6974 0           $slash = 'div';
6975              
6976             # /b /B modifier
6977 0 0         if ($modifier =~ tr/bB//d) {
6978 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6979             }
6980              
6981 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6982 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6983              
6984             # split regexp
6985 0           my @char = $string =~ /\G(
6986             \\o\{ [0-7]+ \} |
6987             \\ [0-7]{2,3} |
6988             \\x\{ [0-9A-Fa-f]+ \} |
6989             \\x [0-9A-Fa-f]{1,2} |
6990             \\c [\x40-\x5F] |
6991             \\N\{ [^0-9\}][^\}]* \} |
6992             \\p\{ [^0-9\}][^\}]* \} |
6993             \\P\{ [^0-9\}][^\}]* \} |
6994             \\ (?:$q_char) |
6995             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6996             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6997             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6998             [\$\@] $qq_variable |
6999             \$ \s* \d+ |
7000             \$ \s* \{ \s* \d+ \s* \} |
7001             \$ \$ (?![\w\{]) |
7002             \$ \s* \$ \s* $qq_variable |
7003             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
7004             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
7005             \[\^ |
7006             \(\? |
7007             (?:$q_char)
7008             )/oxmsg;
7009              
7010 0           my $left_e = 0;
7011 0           my $right_e = 0;
7012 0           for (my $i=0; $i <= $#char; $i++) {
7013              
7014             # "\L\u" --> "\u\L"
7015 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
7016 0           @char[$i,$i+1] = @char[$i+1,$i];
7017             }
7018              
7019             # "\U\l" --> "\l\U"
7020             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7021 0           @char[$i,$i+1] = @char[$i+1,$i];
7022             }
7023              
7024             # octal escape sequence
7025             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7026 0           $char[$i] = Char::Elatin8::octchr($1);
7027             }
7028              
7029             # hexadecimal escape sequence
7030             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7031 0           $char[$i] = Char::Elatin8::hexchr($1);
7032             }
7033              
7034             # \N{CHARNAME} --> N\{CHARNAME}
7035             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7036 0           $char[$i] = $1 . '\\' . $2;
7037             }
7038              
7039             # \p{PROPERTY} --> p\{PROPERTY}
7040             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7041 0           $char[$i] = $1 . '\\' . $2;
7042             }
7043              
7044             # \P{PROPERTY} --> P\{PROPERTY}
7045             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7046 0           $char[$i] = $1 . '\\' . $2;
7047             }
7048              
7049             # \p, \P, \X --> p, P, X
7050             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7051 0           $char[$i] = $1;
7052             }
7053              
7054 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7055             }
7056              
7057             # join separated multiple-octet
7058 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7059 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        
7060 0           $char[$i] .= join '', splice @char, $i+1, 3;
7061             }
7062             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)) {
7063 0           $char[$i] .= join '', splice @char, $i+1, 2;
7064             }
7065             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)) {
7066 0           $char[$i] .= join '', splice @char, $i+1, 1;
7067             }
7068             }
7069              
7070             # open character class [...]
7071             elsif ($char[$i] eq '[') {
7072 0           my $left = $i;
7073 0 0         if ($char[$i+1] eq ']') {
7074 0           $i++;
7075             }
7076 0           while (1) {
7077 0 0         if (++$i > $#char) {
7078 0           die __FILE__, ": Unmatched [] in regexp";
7079             }
7080 0 0         if ($char[$i] eq ']') {
7081 0           my $right = $i;
7082              
7083             # [...]
7084 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7085 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7086             }
7087             else {
7088 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
7089             }
7090              
7091 0           $i = $left;
7092 0           last;
7093             }
7094             }
7095             }
7096              
7097             # open character class [^...]
7098             elsif ($char[$i] eq '[^') {
7099 0           my $left = $i;
7100 0 0         if ($char[$i+1] eq ']') {
7101 0           $i++;
7102             }
7103 0           while (1) {
7104 0 0         if (++$i > $#char) {
7105 0           die __FILE__, ": Unmatched [] in regexp";
7106             }
7107 0 0         if ($char[$i] eq ']') {
7108 0           my $right = $i;
7109              
7110             # [^...]
7111 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7112 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7113             }
7114             else {
7115 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7116             }
7117              
7118 0           $i = $left;
7119 0           last;
7120             }
7121             }
7122             }
7123              
7124             # rewrite character class or escape character
7125             elsif (my $char = character_class($char[$i],$modifier)) {
7126 0           $char[$i] = $char;
7127             }
7128              
7129             # P.794 29.2.161. split
7130             # in Chapter 29: Functions
7131             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7132              
7133             # P.951 split
7134             # in Chapter 27: Functions
7135             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7136              
7137             # said "The //m modifier is assumed when you split on the pattern /^/",
7138             # but perl5.008 is not so. Therefore, this software adds //m.
7139             # (and so on)
7140              
7141             # split(m/^/) --> split(m/^/m)
7142             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7143 0           $modifier .= 'm';
7144             }
7145              
7146             # /i modifier
7147             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin8::uc($char[$i]) ne Char::Elatin8::fc($char[$i]))) {
7148 0 0         if (CORE::length(Char::Elatin8::fc($char[$i])) == 1) {
7149 0           $char[$i] = '[' . Char::Elatin8::uc($char[$i]) . Char::Elatin8::fc($char[$i]) . ']';
7150             }
7151             else {
7152 0           $char[$i] = '(?:' . Char::Elatin8::uc($char[$i]) . '|' . Char::Elatin8::fc($char[$i]) . ')';
7153             }
7154             }
7155              
7156             # \u \l \U \L \F \Q \E
7157             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7158 0 0         if ($right_e < $left_e) {
7159 0           $char[$i] = '\\' . $char[$i];
7160             }
7161             }
7162             elsif ($char[$i] eq '\u') {
7163 0           $char[$i] = '@{[Char::Elatin8::ucfirst qq<';
7164 0           $left_e++;
7165             }
7166             elsif ($char[$i] eq '\l') {
7167 0           $char[$i] = '@{[Char::Elatin8::lcfirst qq<';
7168 0           $left_e++;
7169             }
7170             elsif ($char[$i] eq '\U') {
7171 0           $char[$i] = '@{[Char::Elatin8::uc qq<';
7172 0           $left_e++;
7173             }
7174             elsif ($char[$i] eq '\L') {
7175 0           $char[$i] = '@{[Char::Elatin8::lc qq<';
7176 0           $left_e++;
7177             }
7178             elsif ($char[$i] eq '\F') {
7179 0           $char[$i] = '@{[Char::Elatin8::fc qq<';
7180 0           $left_e++;
7181             }
7182             elsif ($char[$i] eq '\Q') {
7183 0           $char[$i] = '@{[CORE::quotemeta qq<';
7184 0           $left_e++;
7185             }
7186             elsif ($char[$i] eq '\E') {
7187 0 0         if ($right_e < $left_e) {
7188 0           $char[$i] = '>]}';
7189 0           $right_e++;
7190             }
7191             else {
7192 0           $char[$i] = '';
7193             }
7194             }
7195             elsif ($char[$i] eq '\Q') {
7196 0           while (1) {
7197 0 0         if (++$i > $#char) {
7198 0           last;
7199             }
7200 0 0         if ($char[$i] eq '\E') {
7201 0           last;
7202             }
7203             }
7204             }
7205             elsif ($char[$i] eq '\E') {
7206             }
7207              
7208             # $0 --> $0
7209             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7210 0 0         if ($ignorecase) {
7211 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7212             }
7213             }
7214             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
7215 0 0         if ($ignorecase) {
7216 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7217             }
7218             }
7219              
7220             # $$ --> $$
7221             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7222             }
7223              
7224             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7225             # $1, $2, $3 --> $1, $2, $3 otherwise
7226             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
7227 0           $char[$i] = e_capture($1);
7228 0 0         if ($ignorecase) {
7229 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7230             }
7231             }
7232             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
7233 0           $char[$i] = e_capture($1);
7234 0 0         if ($ignorecase) {
7235 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7236             }
7237             }
7238              
7239             # $$foo[ ... ] --> $ $foo->[ ... ]
7240             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7241 0           $char[$i] = e_capture($1.'->'.$2);
7242 0 0         if ($ignorecase) {
7243 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7244             }
7245             }
7246              
7247             # $$foo{ ... } --> $ $foo->{ ... }
7248             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7249 0           $char[$i] = e_capture($1.'->'.$2);
7250 0 0         if ($ignorecase) {
7251 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7252             }
7253             }
7254              
7255             # $$foo
7256             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
7257 0           $char[$i] = e_capture($1);
7258 0 0         if ($ignorecase) {
7259 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7260             }
7261             }
7262              
7263             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin8::PREMATCH()
7264             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
7265 0 0         if ($ignorecase) {
7266 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::PREMATCH())]}';
7267             }
7268             else {
7269 0           $char[$i] = '@{[Char::Elatin8::PREMATCH()]}';
7270             }
7271             }
7272              
7273             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin8::MATCH()
7274             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
7275 0 0         if ($ignorecase) {
7276 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::MATCH())]}';
7277             }
7278             else {
7279 0           $char[$i] = '@{[Char::Elatin8::MATCH()]}';
7280             }
7281             }
7282              
7283             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin8::POSTMATCH()
7284             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
7285 0 0         if ($ignorecase) {
7286 0           $char[$i] = '@{[Char::Elatin8::ignorecase(Char::Elatin8::POSTMATCH())]}';
7287             }
7288             else {
7289 0           $char[$i] = '@{[Char::Elatin8::POSTMATCH()]}';
7290             }
7291             }
7292              
7293             # ${ foo }
7294             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
7295 0 0         if ($ignorecase) {
7296 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $1 . ')]}';
7297             }
7298             }
7299              
7300             # ${ ... }
7301             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
7302 0           $char[$i] = e_capture($1);
7303 0 0         if ($ignorecase) {
7304 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7305             }
7306             }
7307              
7308             # $scalar or @array
7309             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7310 0           $char[$i] = e_string($char[$i]);
7311 0 0         if ($ignorecase) {
7312 0           $char[$i] = '@{[Char::Elatin8::ignorecase(' . $char[$i] . ')]}';
7313             }
7314             }
7315              
7316             # quote character before ? + * {
7317             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7318 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7319             }
7320             else {
7321 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7322             }
7323             }
7324             }
7325              
7326             # make regexp string
7327 0           $modifier =~ tr/i//d;
7328 0 0         if ($left_e > $right_e) {
7329 0           return join '', 'Char::Elatin8::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7330             }
7331 0           return join '', 'Char::Elatin8::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7332             }
7333              
7334             #
7335             # escape regexp of split qr''
7336             #
7337             sub e_split_q {
7338 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7339 0   0       $modifier ||= '';
7340              
7341 0           $modifier =~ tr/p//d;
7342 0 0         if ($modifier =~ /([adlu])/oxms) {
7343 0           my $line = 0;
7344 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7345 0 0         if ($filename ne __FILE__) {
7346 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7347 0           last;
7348             }
7349             }
7350 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7351             }
7352              
7353 0           $slash = 'div';
7354              
7355             # /b /B modifier
7356 0 0         if ($modifier =~ tr/bB//d) {
7357 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7358             }
7359              
7360 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7361              
7362             # split regexp
7363 0           my @char = $string =~ /\G(
7364             \[\:\^ [a-z]+ \:\] |
7365             \[\: [a-z]+ \:\] |
7366             \[\^ |
7367             \\? (?:$q_char)
7368             )/oxmsg;
7369              
7370             # unescape character
7371 0           for (my $i=0; $i <= $#char; $i++) {
7372 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7373             }
7374              
7375             # open character class [...]
7376 0           elsif ($char[$i] eq '[') {
7377 0           my $left = $i;
7378 0 0         if ($char[$i+1] eq ']') {
7379 0           $i++;
7380             }
7381 0           while (1) {
7382 0 0         if (++$i > $#char) {
7383 0           die __FILE__, ": Unmatched [] in regexp";
7384             }
7385 0 0         if ($char[$i] eq ']') {
7386 0           my $right = $i;
7387              
7388             # [...]
7389 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
7390              
7391 0           $i = $left;
7392 0           last;
7393             }
7394             }
7395             }
7396              
7397             # open character class [^...]
7398             elsif ($char[$i] eq '[^') {
7399 0           my $left = $i;
7400 0 0         if ($char[$i+1] eq ']') {
7401 0           $i++;
7402             }
7403 0           while (1) {
7404 0 0         if (++$i > $#char) {
7405 0           die __FILE__, ": Unmatched [] in regexp";
7406             }
7407 0 0         if ($char[$i] eq ']') {
7408 0           my $right = $i;
7409              
7410             # [^...]
7411 0           splice @char, $left, $right-$left+1, Char::Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7412              
7413 0           $i = $left;
7414 0           last;
7415             }
7416             }
7417             }
7418              
7419             # rewrite character class or escape character
7420             elsif (my $char = character_class($char[$i],$modifier)) {
7421 0           $char[$i] = $char;
7422             }
7423              
7424             # split(m/^/) --> split(m/^/m)
7425             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7426 0           $modifier .= 'm';
7427             }
7428              
7429             # /i modifier
7430             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin8::uc($char[$i]) ne Char::Elatin8::fc($char[$i]))) {
7431 0 0         if (CORE::length(Char::Elatin8::fc($char[$i])) == 1) {
7432 0           $char[$i] = '[' . Char::Elatin8::uc($char[$i]) . Char::Elatin8::fc($char[$i]) . ']';
7433             }
7434             else {
7435 0           $char[$i] = '(?:' . Char::Elatin8::uc($char[$i]) . '|' . Char::Elatin8::fc($char[$i]) . ')';
7436             }
7437             }
7438              
7439             # quote character before ? + * {
7440             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7441 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7442             }
7443             else {
7444 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7445             }
7446             }
7447             }
7448              
7449 0           $modifier =~ tr/i//d;
7450 0           return join '', 'Char::Elatin8::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7451             }
7452              
7453             #
7454             # instead of Carp::carp
7455             #
7456             sub carp {
7457 0     0 0   my($package,$filename,$line) = caller(1);
7458 0           print STDERR "@_ at $filename line $line.\n";
7459             }
7460              
7461             #
7462             # instead of Carp::croak
7463             #
7464             sub croak {
7465 0     0 0   my($package,$filename,$line) = caller(1);
7466 0           print STDERR "@_ at $filename line $line.\n";
7467 0           die "\n";
7468             }
7469              
7470             #
7471             # instead of Carp::cluck
7472             #
7473             sub cluck {
7474 0     0 0   my $i = 0;
7475 0           my @cluck = ();
7476 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7477 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7478 0           $i++;
7479             }
7480 0           print STDERR CORE::reverse @cluck;
7481 0           print STDERR "\n";
7482 0           carp @_;
7483             }
7484              
7485             #
7486             # instead of Carp::confess
7487             #
7488             sub confess {
7489 0     0 0   my $i = 0;
7490 0           my @confess = ();
7491 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7492 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7493 0           $i++;
7494             }
7495 0           print STDERR CORE::reverse @confess;
7496 0           print STDERR "\n";
7497 0           croak @_;
7498             }
7499              
7500             1;
7501              
7502             __END__