File Coverage

Char/Elatin10.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::Elatin10;
5             ######################################################################
6             #
7             # Char::Elatin10 - Run-time routines for Char/Latin10.pm
8             #
9             # http://search.cpan.org/dist/Char-Latin10/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
12             ######################################################################
13              
14 197     197   4442 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         615  
  197         11021  
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   26965 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1228  
  197         409  
  197         50230  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 197 50   197   1417 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 197         365 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 197         42908 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   14236 CORE::eval q{
  197     197   1310  
  197     61   379  
  197         29568  
  61         11917  
  70         12610  
  74         16576  
  72         12328  
  64         11402  
  53         8581  
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       140351 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   581 my $genpkg = "Symbol::";
62 197         10248 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::Elatin10::index($name, '::') == -1) && (Char::Elatin10::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   430 if (CORE::eval { local $@; CORE::require strict }) {
  197         366  
  197         2293  
110 197         29793 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   14106 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  197     197   1350  
  197         306  
  197         13661  
140 197     197   12176 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  197     197   1105  
  197         295  
  197         15316  
141 197     197   14315 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  197     197   1156  
  197         372  
  197         15159  
142              
143             #
144             # Latin-10 character range per length
145             #
146             my %range_tr = ();
147              
148             #
149             # alias of encoding name
150             #
151 197     197   13668 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  197     197   1290  
  197         328  
  197         467895  
152              
153             #
154             # Latin-10 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 Elatin10 \z/oxms) {
170             %range_tr = (
171             1 => [ [0x00..0xFF],
172             ],
173             );
174             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-16 | iec[- ]?8859-16 | latin-?10 ) \b /oxmsi;
175              
176             %lc = (%lc,
177             "\xA1" => "\xA2", # LATIN LETTER A WITH OGONEK
178             "\xA3" => "\xB3", # LATIN LETTER L WITH STROKE
179             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
180             "\xAA" => "\xBA", # LATIN LETTER S WITH COMMA BELOW
181             "\xAC" => "\xAE", # LATIN LETTER Z WITH ACUTE
182             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
183             "\xB2" => "\xB9", # LATIN LETTER C WITH CARON
184             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
185             "\xBC" => "\xBD", # LATIN LIGATURE OE
186             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
187             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
188             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
189             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
190             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
191             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
192             "\xC5" => "\xE5", # LATIN LETTER C WITH ACUTE
193             "\xC6" => "\xE6", # LATIN LETTER AE
194             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
195             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
196             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
197             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
198             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
199             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
200             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
201             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
202             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
203             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
204             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
205             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
206             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
207             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
208             "\xD5" => "\xF5", # LATIN LETTER O WITH DOUBLE ACUTE
209             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
210             "\xD7" => "\xF7", # LATIN LETTER S WITH ACUTE
211             "\xD8" => "\xF8", # LATIN LETTER U WITH DOUBLE ACUTE
212             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
213             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
214             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
215             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
216             "\xDD" => "\xFD", # LATIN LETTER E WITH OGONEK
217             "\xDE" => "\xFE", # LATIN LETTER T WITH COMMA BELOW
218             );
219              
220             %uc = (%uc,
221             "\xA2" => "\xA1", # LATIN LETTER A WITH OGONEK
222             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
223             "\xAE" => "\xAC", # LATIN LETTER Z WITH ACUTE
224             "\xB3" => "\xA3", # LATIN LETTER L WITH STROKE
225             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
226             "\xB9" => "\xB2", # LATIN LETTER C WITH CARON
227             "\xBA" => "\xAA", # LATIN LETTER S WITH COMMA BELOW
228             "\xBD" => "\xBC", # LATIN LIGATURE OE
229             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
230             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
231             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
232             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
233             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
234             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
235             "\xE5" => "\xC5", # LATIN LETTER C WITH ACUTE
236             "\xE6" => "\xC6", # LATIN LETTER AE
237             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
238             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
239             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
240             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
241             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
242             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
243             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
244             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
245             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
246             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
247             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
248             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
249             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
250             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
251             "\xF5" => "\xD5", # LATIN LETTER O WITH DOUBLE ACUTE
252             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
253             "\xF7" => "\xD7", # LATIN LETTER S WITH ACUTE
254             "\xF8" => "\xD8", # LATIN LETTER U WITH DOUBLE ACUTE
255             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
256             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
257             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
258             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
259             "\xFD" => "\xDD", # LATIN LETTER E WITH OGONEK
260             "\xFE" => "\xDE", # LATIN LETTER T WITH COMMA BELOW
261             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
262             );
263              
264             %fc = (%fc,
265             "\xA1" => "\xA2", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
266             "\xA3" => "\xB3", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
267             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
268             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH COMMA BELOW --> LATIN SMALL LETTER S WITH COMMA BELOW
269             "\xAC" => "\xAE", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
270             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
271             "\xB2" => "\xB9", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
272             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
273             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
274             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
275             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
276             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
277             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
278             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
279             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
280             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
281             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
282             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
283             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
284             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
285             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
286             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
287             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
288             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
289             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
290             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
291             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
292             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
293             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
294             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
295             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
296             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE --> LATIN SMALL LETTER O WITH DOUBLE ACUTE
297             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
298             "\xD7" => "\xF7", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
299             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE --> LATIN SMALL LETTER U WITH DOUBLE ACUTE
300             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
301             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
302             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
303             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
304             "\xDD" => "\xFD", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
305             "\xDE" => "\xFE", # LATIN CAPITAL LETTER T WITH COMMA BELOW --> LATIN SMALL LETTER T WITH COMMA BELOW
306             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
307             );
308             }
309              
310             else {
311             croak "Don't know my package name '@{[__PACKAGE__]}'";
312             }
313              
314             #
315             # @ARGV wildcard globbing
316             #
317             sub import {
318              
319 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
320 0         0 my @argv = ();
321 0         0 for (@ARGV) {
322              
323             # has space
324 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
325 0 0       0 if (my @glob = Char::Elatin10::glob(qq{"$_"})) {
326 0         0 push @argv, @glob;
327             }
328             else {
329 0         0 push @argv, $_;
330             }
331             }
332              
333             # has wildcard metachar
334             elsif (/\A (?:$q_char)*? [*?] /oxms) {
335 0 0       0 if (my @glob = Char::Elatin10::glob($_)) {
336 0         0 push @argv, @glob;
337             }
338             else {
339 0         0 push @argv, $_;
340             }
341             }
342              
343             # no wildcard globbing
344             else {
345 0         0 push @argv, $_;
346             }
347             }
348 0         0 @ARGV = @argv;
349             }
350             }
351              
352             # P.230 Care with Prototypes
353             # in Chapter 6: Subroutines
354             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
355             #
356             # If you aren't careful, you can get yourself into trouble with prototypes.
357             # But if you are careful, you can do a lot of neat things with them. This is
358             # all very powerful, of course, and should only be used in moderation to make
359             # the world a better place.
360              
361             # P.332 Care with Prototypes
362             # in Chapter 7: Subroutines
363             # of ISBN 978-0-596-00492-7 Programming Perl 4th 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             #
371             # Prototypes of subroutines
372             #
373 0     0   0 sub unimport {}
374             sub Char::Elatin10::split(;$$$);
375             sub Char::Elatin10::tr($$$$;$);
376             sub Char::Elatin10::chop(@);
377             sub Char::Elatin10::index($$;$);
378             sub Char::Elatin10::rindex($$;$);
379             sub Char::Elatin10::lcfirst(@);
380             sub Char::Elatin10::lcfirst_();
381             sub Char::Elatin10::lc(@);
382             sub Char::Elatin10::lc_();
383             sub Char::Elatin10::ucfirst(@);
384             sub Char::Elatin10::ucfirst_();
385             sub Char::Elatin10::uc(@);
386             sub Char::Elatin10::uc_();
387             sub Char::Elatin10::fc(@);
388             sub Char::Elatin10::fc_();
389             sub Char::Elatin10::ignorecase;
390             sub Char::Elatin10::classic_character_class;
391             sub Char::Elatin10::capture;
392             sub Char::Elatin10::chr(;$);
393             sub Char::Elatin10::chr_();
394             sub Char::Elatin10::glob($);
395             sub Char::Elatin10::glob_();
396              
397             sub Char::Latin10::ord(;$);
398             sub Char::Latin10::ord_();
399             sub Char::Latin10::reverse(@);
400             sub Char::Latin10::getc(;*@);
401             sub Char::Latin10::length(;$);
402             sub Char::Latin10::substr($$;$$);
403             sub Char::Latin10::index($$;$);
404             sub Char::Latin10::rindex($$;$);
405             sub Char::Latin10::escape(;$);
406              
407             #
408             # Regexp work
409             #
410 197     197   21150 BEGIN { CORE::eval q{ use vars qw(
  197     197   1577  
  197         348  
  197         91435  
411             $Char::Latin10::re_a
412             $Char::Latin10::re_t
413             $Char::Latin10::re_n
414             $Char::Latin10::re_r
415             ) } }
416              
417             #
418             # Character class
419             #
420 197     197   16211 BEGIN { CORE::eval q{ use vars qw(
  197     197   1241  
  197         453  
  197         3526962  
421             $dot
422             $dot_s
423             $eD
424             $eS
425             $eW
426             $eH
427             $eV
428             $eR
429             $eN
430             $not_alnum
431             $not_alpha
432             $not_ascii
433             $not_blank
434             $not_cntrl
435             $not_digit
436             $not_graph
437             $not_lower
438             $not_lower_i
439             $not_print
440             $not_punct
441             $not_space
442             $not_upper
443             $not_upper_i
444             $not_word
445             $not_xdigit
446             $eb
447             $eB
448             ) } }
449              
450             ${Char::Elatin10::dot} = qr{(?:[^\x0A])};
451             ${Char::Elatin10::dot_s} = qr{(?:[\x00-\xFF])};
452             ${Char::Elatin10::eD} = qr{(?:[^0-9])};
453              
454             # Vertical tabs are now whitespace
455             # \s in a regex now matches a vertical tab in all circumstances.
456             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
457             # ${Char::Elatin10::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
458             # ${Char::Elatin10::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
459             ${Char::Elatin10::eS} = qr{(?:[^\s])};
460              
461             ${Char::Elatin10::eW} = qr{(?:[^0-9A-Z_a-z])};
462             ${Char::Elatin10::eH} = qr{(?:[^\x09\x20])};
463             ${Char::Elatin10::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
464             ${Char::Elatin10::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
465             ${Char::Elatin10::eN} = qr{(?:[^\x0A])};
466             ${Char::Elatin10::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
467             ${Char::Elatin10::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
468             ${Char::Elatin10::not_ascii} = qr{(?:[^\x00-\x7F])};
469             ${Char::Elatin10::not_blank} = qr{(?:[^\x09\x20])};
470             ${Char::Elatin10::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
471             ${Char::Elatin10::not_digit} = qr{(?:[^\x30-\x39])};
472             ${Char::Elatin10::not_graph} = qr{(?:[^\x21-\x7F])};
473             ${Char::Elatin10::not_lower} = qr{(?:[^\x61-\x7A])};
474             ${Char::Elatin10::not_lower_i} = qr{(?:[\x00-\xFF])};
475             ${Char::Elatin10::not_print} = qr{(?:[^\x20-\x7F])};
476             ${Char::Elatin10::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
477             ${Char::Elatin10::not_space} = qr{(?:[^\s\x0B])};
478             ${Char::Elatin10::not_upper} = qr{(?:[^\x41-\x5A])};
479             ${Char::Elatin10::not_upper_i} = qr{(?:[\x00-\xFF])};
480             ${Char::Elatin10::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
481             ${Char::Elatin10::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
482             ${Char::Elatin10::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))};
483             ${Char::Elatin10::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]))};
484              
485             # avoid: Name "Char::Elatin10::foo" used only once: possible typo at here.
486             ${Char::Elatin10::dot} = ${Char::Elatin10::dot};
487             ${Char::Elatin10::dot_s} = ${Char::Elatin10::dot_s};
488             ${Char::Elatin10::eD} = ${Char::Elatin10::eD};
489             ${Char::Elatin10::eS} = ${Char::Elatin10::eS};
490             ${Char::Elatin10::eW} = ${Char::Elatin10::eW};
491             ${Char::Elatin10::eH} = ${Char::Elatin10::eH};
492             ${Char::Elatin10::eV} = ${Char::Elatin10::eV};
493             ${Char::Elatin10::eR} = ${Char::Elatin10::eR};
494             ${Char::Elatin10::eN} = ${Char::Elatin10::eN};
495             ${Char::Elatin10::not_alnum} = ${Char::Elatin10::not_alnum};
496             ${Char::Elatin10::not_alpha} = ${Char::Elatin10::not_alpha};
497             ${Char::Elatin10::not_ascii} = ${Char::Elatin10::not_ascii};
498             ${Char::Elatin10::not_blank} = ${Char::Elatin10::not_blank};
499             ${Char::Elatin10::not_cntrl} = ${Char::Elatin10::not_cntrl};
500             ${Char::Elatin10::not_digit} = ${Char::Elatin10::not_digit};
501             ${Char::Elatin10::not_graph} = ${Char::Elatin10::not_graph};
502             ${Char::Elatin10::not_lower} = ${Char::Elatin10::not_lower};
503             ${Char::Elatin10::not_lower_i} = ${Char::Elatin10::not_lower_i};
504             ${Char::Elatin10::not_print} = ${Char::Elatin10::not_print};
505             ${Char::Elatin10::not_punct} = ${Char::Elatin10::not_punct};
506             ${Char::Elatin10::not_space} = ${Char::Elatin10::not_space};
507             ${Char::Elatin10::not_upper} = ${Char::Elatin10::not_upper};
508             ${Char::Elatin10::not_upper_i} = ${Char::Elatin10::not_upper_i};
509             ${Char::Elatin10::not_word} = ${Char::Elatin10::not_word};
510             ${Char::Elatin10::not_xdigit} = ${Char::Elatin10::not_xdigit};
511             ${Char::Elatin10::eb} = ${Char::Elatin10::eb};
512             ${Char::Elatin10::eB} = ${Char::Elatin10::eB};
513              
514             #
515             # Latin-10 split
516             #
517             sub Char::Elatin10::split(;$$$) {
518              
519             # P.794 29.2.161. split
520             # in Chapter 29: Functions
521             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
522              
523             # P.951 split
524             # in Chapter 27: Functions
525             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
526              
527 0     0 0 0 my $pattern = $_[0];
528 0         0 my $string = $_[1];
529 0         0 my $limit = $_[2];
530              
531             # if $pattern is also omitted or is the literal space, " "
532 0 0       0 if (not defined $pattern) {
533 0         0 $pattern = ' ';
534             }
535              
536             # if $string is omitted, the function splits the $_ string
537 0 0       0 if (not defined $string) {
538 0 0       0 if (defined $_) {
539 0         0 $string = $_;
540             }
541             else {
542 0         0 $string = '';
543             }
544             }
545              
546 0         0 my @split = ();
547              
548             # when string is empty
549 0 0       0 if ($string eq '') {
    0          
550              
551             # resulting list value in list context
552 0 0       0 if (wantarray) {
553 0         0 return @split;
554             }
555              
556             # count of substrings in scalar context
557             else {
558 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
559 0         0 @_ = @split;
560 0         0 return scalar @_;
561             }
562             }
563              
564             # split's first argument is more consistently interpreted
565             #
566             # After some changes earlier in v5.17, split's behavior has been simplified:
567             # if the PATTERN argument evaluates to a string containing one space, it is
568             # treated the way that a literal string containing one space once was.
569             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
570              
571             # if $pattern is also omitted or is the literal space, " ", the function splits
572             # on whitespace, /\s+/, after skipping any leading whitespace
573             # (and so on)
574              
575             elsif ($pattern eq ' ') {
576 0 0       0 if (not defined $limit) {
577 0         0 return CORE::split(' ', $string);
578             }
579             else {
580 0         0 return CORE::split(' ', $string, $limit);
581             }
582             }
583              
584             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
585 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
586              
587             # a pattern capable of matching either the null string or something longer than the
588             # null string will split the value of $string into separate characters wherever it
589             # matches the null string between characters
590             # (and so on)
591              
592 0 0       0 if ('' =~ / \A $pattern \z /xms) {
593 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
594 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
595              
596             # P.1024 Appendix W.10 Multibyte Processing
597             # of ISBN 1-56592-224-7 CJKV Information Processing
598             # (and so on)
599              
600             # the //m modifier is assumed when you split on the pattern /^/
601             # (and so on)
602              
603             # V
604 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
605              
606             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
607             # is included in the resulting list, interspersed with the fields that are ordinarily returned
608             # (and so on)
609              
610 0         0 local $@;
611 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
612 0         0 push @split, CORE::eval('$' . $digit);
613             }
614             }
615             }
616              
617             else {
618 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
619              
620             # V
621 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
622 0         0 local $@;
623 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
624 0         0 push @split, CORE::eval('$' . $digit);
625             }
626             }
627             }
628             }
629              
630             elsif ($limit > 0) {
631 0 0       0 if ('' =~ / \A $pattern \z /xms) {
632 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
633 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
634              
635             # V
636 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
637 0         0 local $@;
638 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
639 0         0 push @split, CORE::eval('$' . $digit);
640             }
641             }
642             }
643             }
644             else {
645 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
646 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
647              
648             # V
649 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
650 0         0 local $@;
651 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
652 0         0 push @split, CORE::eval('$' . $digit);
653             }
654             }
655             }
656             }
657             }
658              
659 0 0       0 if (CORE::length($string) > 0) {
660 0         0 push @split, $string;
661             }
662              
663             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
664 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
665 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
666 0         0 pop @split;
667             }
668             }
669              
670             # resulting list value in list context
671 0 0       0 if (wantarray) {
672 0         0 return @split;
673             }
674              
675             # count of substrings in scalar context
676             else {
677 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
678 0         0 @_ = @split;
679 0         0 return scalar @_;
680             }
681             }
682              
683             #
684             # get last subexpression offsets
685             #
686             sub _last_subexpression_offsets {
687 0     0   0 my $pattern = $_[0];
688              
689             # remove comment
690 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
691              
692 0         0 my $modifier = '';
693 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
694 0         0 $modifier = $1;
695 0         0 $modifier =~ s/-[A-Za-z]*//;
696             }
697              
698             # with /x modifier
699 0         0 my @char = ();
700 0 0       0 if ($modifier =~ /x/oxms) {
701 0         0 @char = $pattern =~ /\G(
702             \\ (?:$q_char) |
703             \# (?:$q_char)*? $ |
704             \[ (?: \\\] | (?:$q_char))+? \] |
705             \(\? |
706             (?:$q_char)
707             )/oxmsg;
708             }
709              
710             # without /x modifier
711             else {
712 0         0 @char = $pattern =~ /\G(
713             \\ (?:$q_char) |
714             \[ (?: \\\] | (?:$q_char))+? \] |
715             \(\? |
716             (?:$q_char)
717             )/oxmsg;
718             }
719              
720 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
721             }
722              
723             #
724             # Latin-10 transliteration (tr///)
725             #
726             sub Char::Elatin10::tr($$$$;$) {
727              
728 0     0 0 0 my $bind_operator = $_[1];
729 0         0 my $searchlist = $_[2];
730 0         0 my $replacementlist = $_[3];
731 0   0     0 my $modifier = $_[4] || '';
732              
733 0 0       0 if ($modifier =~ /r/oxms) {
734 0 0       0 if ($bind_operator =~ / !~ /oxms) {
735 0         0 croak "Using !~ with tr///r doesn't make sense";
736             }
737             }
738              
739 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
740 0         0 my @searchlist = _charlist_tr($searchlist);
741 0         0 my @replacementlist = _charlist_tr($replacementlist);
742              
743 0         0 my %tr = ();
744 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
745 0 0       0 if (not exists $tr{$searchlist[$i]}) {
746 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
747 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
748             }
749             elsif ($modifier =~ /d/oxms) {
750 0         0 $tr{$searchlist[$i]} = '';
751             }
752             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
753 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
754             }
755             else {
756 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
757             }
758             }
759             }
760              
761 0         0 my $tr = 0;
762 0         0 my $replaced = '';
763 0 0       0 if ($modifier =~ /c/oxms) {
764 0         0 while (defined(my $char = shift @char)) {
765 0 0       0 if (not exists $tr{$char}) {
766 0 0       0 if (defined $replacementlist[0]) {
767 0         0 $replaced .= $replacementlist[0];
768             }
769 0         0 $tr++;
770 0 0       0 if ($modifier =~ /s/oxms) {
771 0   0     0 while (@char and (not exists $tr{$char[0]})) {
772 0         0 shift @char;
773 0         0 $tr++;
774             }
775             }
776             }
777             else {
778 0         0 $replaced .= $char;
779             }
780             }
781             }
782             else {
783 0         0 while (defined(my $char = shift @char)) {
784 0 0       0 if (exists $tr{$char}) {
785 0         0 $replaced .= $tr{$char};
786 0         0 $tr++;
787 0 0       0 if ($modifier =~ /s/oxms) {
788 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
789 0         0 shift @char;
790 0         0 $tr++;
791             }
792             }
793             }
794             else {
795 0         0 $replaced .= $char;
796             }
797             }
798             }
799              
800 0 0       0 if ($modifier =~ /r/oxms) {
801 0         0 return $replaced;
802             }
803             else {
804 0         0 $_[0] = $replaced;
805 0 0       0 if ($bind_operator =~ / !~ /oxms) {
806 0         0 return not $tr;
807             }
808             else {
809 0         0 return $tr;
810             }
811             }
812             }
813              
814             #
815             # Latin-10 chop
816             #
817             sub Char::Elatin10::chop(@) {
818              
819 0     0 0 0 my $chop;
820 0 0       0 if (@_ == 0) {
821 0         0 my @char = /\G ($q_char) /oxmsg;
822 0         0 $chop = pop @char;
823 0         0 $_ = join '', @char;
824             }
825             else {
826 0         0 for (@_) {
827 0         0 my @char = /\G ($q_char) /oxmsg;
828 0         0 $chop = pop @char;
829 0         0 $_ = join '', @char;
830             }
831             }
832 0         0 return $chop;
833             }
834              
835             #
836             # Latin-10 index by octet
837             #
838             sub Char::Elatin10::index($$;$) {
839              
840 0     0 1 0 my($str,$substr,$position) = @_;
841 0   0     0 $position ||= 0;
842 0         0 my $pos = 0;
843              
844 0         0 while ($pos < CORE::length($str)) {
845 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
846 0 0       0 if ($pos >= $position) {
847 0         0 return $pos;
848             }
849             }
850 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
851 0         0 $pos += CORE::length($1);
852             }
853             else {
854 0         0 $pos += 1;
855             }
856             }
857 0         0 return -1;
858             }
859              
860             #
861             # Latin-10 reverse index
862             #
863             sub Char::Elatin10::rindex($$;$) {
864              
865 0     0 0 0 my($str,$substr,$position) = @_;
866 0   0     0 $position ||= CORE::length($str) - 1;
867 0         0 my $pos = 0;
868 0         0 my $rindex = -1;
869              
870 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
871 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
872 0         0 $rindex = $pos;
873             }
874 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
875 0         0 $pos += CORE::length($1);
876             }
877             else {
878 0         0 $pos += 1;
879             }
880             }
881 0         0 return $rindex;
882             }
883              
884             #
885             # Latin-10 lower case first with parameter
886             #
887             sub Char::Elatin10::lcfirst(@) {
888 0 0   0 0 0 if (@_) {
889 0         0 my $s = shift @_;
890 0 0 0     0 if (@_ and wantarray) {
891 0         0 return Char::Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
892             }
893             else {
894 0         0 return Char::Elatin10::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
895             }
896             }
897             else {
898 0         0 return Char::Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
899             }
900             }
901              
902             #
903             # Latin-10 lower case first without parameter
904             #
905             sub Char::Elatin10::lcfirst_() {
906 0     0 0 0 return Char::Elatin10::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
907             }
908              
909             #
910             # Latin-10 lower case with parameter
911             #
912             sub Char::Elatin10::lc(@) {
913 0 0   0 0 0 if (@_) {
914 0         0 my $s = shift @_;
915 0 0 0     0 if (@_ and wantarray) {
916 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
917             }
918             else {
919 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
920             }
921             }
922             else {
923 0         0 return Char::Elatin10::lc_();
924             }
925             }
926              
927             #
928             # Latin-10 lower case without parameter
929             #
930             sub Char::Elatin10::lc_() {
931 0     0 0 0 my $s = $_;
932 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
933             }
934              
935             #
936             # Latin-10 upper case first with parameter
937             #
938             sub Char::Elatin10::ucfirst(@) {
939 0 0   0 0 0 if (@_) {
940 0         0 my $s = shift @_;
941 0 0 0     0 if (@_ and wantarray) {
942 0         0 return Char::Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
943             }
944             else {
945 0         0 return Char::Elatin10::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
946             }
947             }
948             else {
949 0         0 return Char::Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
950             }
951             }
952              
953             #
954             # Latin-10 upper case first without parameter
955             #
956             sub Char::Elatin10::ucfirst_() {
957 0     0 0 0 return Char::Elatin10::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
958             }
959              
960             #
961             # Latin-10 upper case with parameter
962             #
963             sub Char::Elatin10::uc(@) {
964 0 0   0 0 0 if (@_) {
965 0         0 my $s = shift @_;
966 0 0 0     0 if (@_ and wantarray) {
967 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
968             }
969             else {
970 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
971             }
972             }
973             else {
974 0         0 return Char::Elatin10::uc_();
975             }
976             }
977              
978             #
979             # Latin-10 upper case without parameter
980             #
981             sub Char::Elatin10::uc_() {
982 0     0 0 0 my $s = $_;
983 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
984             }
985              
986             #
987             # Latin-10 fold case with parameter
988             #
989             sub Char::Elatin10::fc(@) {
990 0 0   0 0 0 if (@_) {
991 0         0 my $s = shift @_;
992 0 0 0     0 if (@_ and wantarray) {
993 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
994             }
995             else {
996 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
997             }
998             }
999             else {
1000 0         0 return Char::Elatin10::fc_();
1001             }
1002             }
1003              
1004             #
1005             # Latin-10 fold case without parameter
1006             #
1007             sub Char::Elatin10::fc_() {
1008 0     0 0 0 my $s = $_;
1009 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1010             }
1011              
1012             #
1013             # Latin-10 regexp capture
1014             #
1015             {
1016             sub Char::Elatin10::capture {
1017 0     0 1 0 return $_[0];
1018             }
1019             }
1020              
1021             #
1022             # Latin-10 regexp ignore case modifier
1023             #
1024             sub Char::Elatin10::ignorecase {
1025              
1026 0     0 0 0 my @string = @_;
1027 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1028              
1029             # ignore case of $scalar or @array
1030 0         0 for my $string (@string) {
1031              
1032             # split regexp
1033 0         0 my @char = $string =~ /\G(
1034             \[\^ |
1035             \\? (?:$q_char)
1036             )/oxmsg;
1037              
1038             # unescape character
1039 0         0 for (my $i=0; $i <= $#char; $i++) {
1040 0 0       0 next if not defined $char[$i];
1041              
1042             # open character class [...]
1043 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1044 0         0 my $left = $i;
1045              
1046             # [] make die "unmatched [] in regexp ..."
1047              
1048 0 0       0 if ($char[$i+1] eq ']') {
1049 0         0 $i++;
1050             }
1051              
1052 0         0 while (1) {
1053 0 0       0 if (++$i > $#char) {
1054 0         0 croak "Unmatched [] in regexp";
1055             }
1056 0 0       0 if ($char[$i] eq ']') {
1057 0         0 my $right = $i;
1058 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1059              
1060             # escape character
1061 0         0 for my $char (@charlist) {
1062 0 0       0 if (0) {
1063             }
1064              
1065 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1066 0         0 $char = $1 . '\\' . $char;
1067             }
1068             }
1069              
1070             # [...]
1071 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1072              
1073 0         0 $i = $left;
1074 0         0 last;
1075             }
1076             }
1077             }
1078              
1079             # open character class [^...]
1080             elsif ($char[$i] eq '[^') {
1081 0         0 my $left = $i;
1082              
1083             # [^] make die "unmatched [] in regexp ..."
1084              
1085 0 0       0 if ($char[$i+1] eq ']') {
1086 0         0 $i++;
1087             }
1088              
1089 0         0 while (1) {
1090 0 0       0 if (++$i > $#char) {
1091 0         0 croak "Unmatched [] in regexp";
1092             }
1093 0 0       0 if ($char[$i] eq ']') {
1094 0         0 my $right = $i;
1095 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1096              
1097             # escape character
1098 0         0 for my $char (@charlist) {
1099 0 0       0 if (0) {
1100             }
1101              
1102 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1103 0         0 $char = '\\' . $char;
1104             }
1105             }
1106              
1107             # [^...]
1108 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1109              
1110 0         0 $i = $left;
1111 0         0 last;
1112             }
1113             }
1114             }
1115              
1116             # rewrite classic character class or escape character
1117             elsif (my $char = classic_character_class($char[$i])) {
1118 0         0 $char[$i] = $char;
1119             }
1120              
1121             # with /i modifier
1122             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1123 0         0 my $uc = Char::Elatin10::uc($char[$i]);
1124 0         0 my $fc = Char::Elatin10::fc($char[$i]);
1125 0 0       0 if ($uc ne $fc) {
1126 0 0       0 if (CORE::length($fc) == 1) {
1127 0         0 $char[$i] = '[' . $uc . $fc . ']';
1128             }
1129             else {
1130 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1131             }
1132             }
1133             }
1134             }
1135              
1136             # characterize
1137 0         0 for (my $i=0; $i <= $#char; $i++) {
1138 0 0       0 next if not defined $char[$i];
1139              
1140 0 0       0 if (0) {
1141             }
1142              
1143             # quote character before ? + * {
1144 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1145 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1146 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1147             }
1148             }
1149             }
1150              
1151 0         0 $string = join '', @char;
1152             }
1153              
1154             # make regexp string
1155 0         0 return @string;
1156             }
1157              
1158             #
1159             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1160             #
1161             sub Char::Elatin10::classic_character_class {
1162 0     0 0 0 my($char) = @_;
1163              
1164             return {
1165 0   0     0 '\D' => '${Char::Elatin10::eD}',
1166             '\S' => '${Char::Elatin10::eS}',
1167             '\W' => '${Char::Elatin10::eW}',
1168             '\d' => '[0-9]',
1169              
1170             # Before Perl 5.6, \s only matched the five whitespace characters
1171             # tab, newline, form-feed, carriage return, and the space character
1172             # itself, which, taken together, is the character class [\t\n\f\r ].
1173              
1174             # Vertical tabs are now whitespace
1175             # \s in a regex now matches a vertical tab in all circumstances.
1176             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1177             # \t \n \v \f \r space
1178             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1179             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1180             '\s' => '\s',
1181              
1182             '\w' => '[0-9A-Z_a-z]',
1183             '\C' => '[\x00-\xFF]',
1184             '\X' => 'X',
1185              
1186             # \h \v \H \V
1187              
1188             # P.114 Character Class Shortcuts
1189             # in Chapter 7: In the World of Regular Expressions
1190             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1191              
1192             # P.357 13.2.3 Whitespace
1193             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1194             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1195             #
1196             # 0x00009 CHARACTER TABULATION h s
1197             # 0x0000a LINE FEED (LF) vs
1198             # 0x0000b LINE TABULATION v
1199             # 0x0000c FORM FEED (FF) vs
1200             # 0x0000d CARRIAGE RETURN (CR) vs
1201             # 0x00020 SPACE h s
1202              
1203             # P.196 Table 5-9. Alphanumeric regex metasymbols
1204             # in Chapter 5. Pattern Matching
1205             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1206              
1207             # (and so on)
1208              
1209             '\H' => '${Char::Elatin10::eH}',
1210             '\V' => '${Char::Elatin10::eV}',
1211             '\h' => '[\x09\x20]',
1212             '\v' => '[\x0A\x0B\x0C\x0D]',
1213             '\R' => '${Char::Elatin10::eR}',
1214              
1215             # \N
1216             #
1217             # http://perldoc.perl.org/perlre.html
1218             # Character Classes and other Special Escapes
1219             # Any character but \n (experimental). Not affected by /s modifier
1220              
1221             '\N' => '${Char::Elatin10::eN}',
1222              
1223             # \b \B
1224              
1225             # P.180 Boundaries: The \b and \B Assertions
1226             # in Chapter 5: Pattern Matching
1227             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1228              
1229             # P.219 Boundaries: The \b and \B Assertions
1230             # in Chapter 5: Pattern Matching
1231             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1232              
1233             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1234             '\b' => '${Char::Elatin10::eb}',
1235              
1236             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1237             '\B' => '${Char::Elatin10::eB}',
1238              
1239             }->{$char} || '';
1240             }
1241              
1242             #
1243             # prepare Latin-10 characters per length
1244             #
1245              
1246             # 1 octet characters
1247             my @chars1 = ();
1248             sub chars1 {
1249 0 0   0 0 0 if (@chars1) {
1250 0         0 return @chars1;
1251             }
1252 0 0       0 if (exists $range_tr{1}) {
1253 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1254 0         0 while (my @range = splice(@ranges,0,1)) {
1255 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1256 0         0 push @chars1, pack 'C', $oct0;
1257             }
1258             }
1259             }
1260 0         0 return @chars1;
1261             }
1262              
1263             # 2 octets characters
1264             my @chars2 = ();
1265             sub chars2 {
1266 0 0   0 0 0 if (@chars2) {
1267 0         0 return @chars2;
1268             }
1269 0 0       0 if (exists $range_tr{2}) {
1270 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1271 0         0 while (my @range = splice(@ranges,0,2)) {
1272 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1273 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1274 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1275             }
1276             }
1277             }
1278             }
1279 0         0 return @chars2;
1280             }
1281              
1282             # 3 octets characters
1283             my @chars3 = ();
1284             sub chars3 {
1285 0 0   0 0 0 if (@chars3) {
1286 0         0 return @chars3;
1287             }
1288 0 0       0 if (exists $range_tr{3}) {
1289 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1290 0         0 while (my @range = splice(@ranges,0,3)) {
1291 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1292 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1293 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1294 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1295             }
1296             }
1297             }
1298             }
1299             }
1300 0         0 return @chars3;
1301             }
1302              
1303             # 4 octets characters
1304             my @chars4 = ();
1305             sub chars4 {
1306 0 0   0 0 0 if (@chars4) {
1307 0         0 return @chars4;
1308             }
1309 0 0       0 if (exists $range_tr{4}) {
1310 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1311 0         0 while (my @range = splice(@ranges,0,4)) {
1312 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1313 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1314 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1315 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1316 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1317             }
1318             }
1319             }
1320             }
1321             }
1322             }
1323 0         0 return @chars4;
1324             }
1325              
1326             #
1327             # Latin-10 open character list for tr
1328             #
1329             sub _charlist_tr {
1330              
1331 0     0   0 local $_ = shift @_;
1332              
1333             # unescape character
1334 0         0 my @char = ();
1335 0         0 while (not /\G \z/oxmsgc) {
1336 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1337 0         0 push @char, '\-';
1338             }
1339             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(oct $1);
1341             }
1342             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1343 0         0 push @char, CORE::chr(hex $1);
1344             }
1345             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1346 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1347             }
1348             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1349 0         0 push @char, {
1350             '\0' => "\0",
1351             '\n' => "\n",
1352             '\r' => "\r",
1353             '\t' => "\t",
1354             '\f' => "\f",
1355             '\b' => "\x08", # \b means backspace in character class
1356             '\a' => "\a",
1357             '\e' => "\e",
1358             }->{$1};
1359             }
1360             elsif (/\G \\ ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             elsif (/\G ($q_char) /oxmsgc) {
1364 0         0 push @char, $1;
1365             }
1366             }
1367              
1368             # join separated multiple-octet
1369 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1370              
1371             # unescape '-'
1372 0         0 my @i = ();
1373 0         0 for my $i (0 .. $#char) {
1374 0 0       0 if ($char[$i] eq '\-') {
    0          
1375 0         0 $char[$i] = '-';
1376             }
1377             elsif ($char[$i] eq '-') {
1378 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1379 0         0 push @i, $i;
1380             }
1381             }
1382             }
1383              
1384             # open character list (reverse for splice)
1385 0         0 for my $i (CORE::reverse @i) {
1386 0         0 my @range = ();
1387              
1388             # range error
1389 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1390 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1391             }
1392              
1393             # range of multiple-octet code
1394 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1395 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1396 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1397             }
1398             elsif (CORE::length($char[$i+1]) == 2) {
1399 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1400 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1401             }
1402             elsif (CORE::length($char[$i+1]) == 3) {
1403 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1404 0         0 push @range, chars2();
1405 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1406             }
1407             elsif (CORE::length($char[$i+1]) == 4) {
1408 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1409 0         0 push @range, chars2();
1410 0         0 push @range, chars3();
1411 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1412             }
1413             else {
1414 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1415             }
1416             }
1417             elsif (CORE::length($char[$i-1]) == 2) {
1418 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1419 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1420             }
1421             elsif (CORE::length($char[$i+1]) == 3) {
1422 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1423 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1424             }
1425             elsif (CORE::length($char[$i+1]) == 4) {
1426 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1427 0         0 push @range, chars3();
1428 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1429             }
1430             else {
1431 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1432             }
1433             }
1434             elsif (CORE::length($char[$i-1]) == 3) {
1435 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1436 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1437             }
1438             elsif (CORE::length($char[$i+1]) == 4) {
1439 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1440 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1441             }
1442             else {
1443 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1444             }
1445             }
1446             elsif (CORE::length($char[$i-1]) == 4) {
1447 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1448 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1449             }
1450             else {
1451 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1452             }
1453             }
1454             else {
1455 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1456             }
1457              
1458 0         0 splice @char, $i-1, 3, @range;
1459             }
1460              
1461 0         0 return @char;
1462             }
1463              
1464             #
1465             # Latin-10 open character class
1466             #
1467             sub _cc {
1468 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1469 0         0 die __FILE__, ": subroutine cc got no parameter.";
1470             }
1471             elsif (scalar(@_) == 1) {
1472 0         0 return sprintf('\x%02X',$_[0]);
1473             }
1474             elsif (scalar(@_) == 2) {
1475 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1476 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1477             }
1478             elsif ($_[0] == $_[1]) {
1479 0         0 return sprintf('\x%02X',$_[0]);
1480             }
1481             elsif (($_[0]+1) == $_[1]) {
1482 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1483             }
1484             else {
1485 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1486             }
1487             }
1488             else {
1489 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1490             }
1491             }
1492              
1493             #
1494             # Latin-10 octet range
1495             #
1496             sub _octets {
1497 0     0   0 my $length = shift @_;
1498              
1499 0 0       0 if ($length == 1) {
1500 0         0 my($a1) = unpack 'C', $_[0];
1501 0         0 my($z1) = unpack 'C', $_[1];
1502              
1503 0 0       0 if ($a1 > $z1) {
1504 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1505             }
1506              
1507 0 0       0 if ($a1 == $z1) {
    0          
1508 0         0 return sprintf('\x%02X',$a1);
1509             }
1510             elsif (($a1+1) == $z1) {
1511 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1512             }
1513             else {
1514 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1515             }
1516             }
1517             else {
1518 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1519             }
1520             }
1521              
1522             #
1523             # Latin-10 range regexp
1524             #
1525             sub _range_regexp {
1526 0     0   0 my($length,$first,$last) = @_;
1527              
1528 0         0 my @range_regexp = ();
1529 0 0       0 if (not exists $range_tr{$length}) {
1530 0         0 return @range_regexp;
1531             }
1532              
1533 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1534 0         0 while (my @range = splice(@ranges,0,$length)) {
1535 0         0 my $min = '';
1536 0         0 my $max = '';
1537 0         0 for (my $i=0; $i < $length; $i++) {
1538 0         0 $min .= pack 'C', $range[$i][0];
1539 0         0 $max .= pack 'C', $range[$i][-1];
1540             }
1541              
1542             # min___max
1543             # FIRST_____________LAST
1544             # (nothing)
1545              
1546 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1547             }
1548              
1549             # **********
1550             # min_________max
1551             # FIRST_____________LAST
1552             # **********
1553              
1554             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1555 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1556             }
1557              
1558             # **********************
1559             # min________________max
1560             # FIRST_____________LAST
1561             # **********************
1562              
1563             elsif (($min eq $first) and ($max eq $last)) {
1564 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1565             }
1566              
1567             # *********
1568             # min___max
1569             # FIRST_____________LAST
1570             # *********
1571              
1572             elsif (($first le $min) and ($max le $last)) {
1573 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1574             }
1575              
1576             # **********************
1577             # min__________________________max
1578             # FIRST_____________LAST
1579             # **********************
1580              
1581             elsif (($min le $first) and ($last le $max)) {
1582 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1583             }
1584              
1585             # *********
1586             # min________max
1587             # FIRST_____________LAST
1588             # *********
1589              
1590             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1591 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1592             }
1593              
1594             # min___max
1595             # FIRST_____________LAST
1596             # (nothing)
1597              
1598             elsif ($last lt $min) {
1599             }
1600              
1601             else {
1602 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1603             }
1604             }
1605              
1606 0         0 return @range_regexp;
1607             }
1608              
1609             #
1610             # Latin-10 open character list for qr and not qr
1611             #
1612             sub _charlist {
1613              
1614 0     0   0 my $modifier = pop @_;
1615 0         0 my @char = @_;
1616              
1617 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1618              
1619             # unescape character
1620 0         0 for (my $i=0; $i <= $#char; $i++) {
1621              
1622             # escape - to ...
1623 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1624 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1625 0         0 $char[$i] = '...';
1626             }
1627             }
1628              
1629             # octal escape sequence
1630             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1631 0         0 $char[$i] = octchr($1);
1632             }
1633              
1634             # hexadecimal escape sequence
1635             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1636 0         0 $char[$i] = hexchr($1);
1637             }
1638              
1639             # \N{CHARNAME} --> N\{CHARNAME}
1640             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1641 0         0 $char[$i] = $1 . '\\' . $2;
1642             }
1643              
1644             # \p{PROPERTY} --> p\{PROPERTY}
1645             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1646 0         0 $char[$i] = $1 . '\\' . $2;
1647             }
1648              
1649             # \P{PROPERTY} --> P\{PROPERTY}
1650             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1651 0         0 $char[$i] = $1 . '\\' . $2;
1652             }
1653              
1654             # \p, \P, \X --> p, P, X
1655             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1656 0         0 $char[$i] = $1;
1657             }
1658              
1659             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1660 0         0 $char[$i] = CORE::chr oct $1;
1661             }
1662             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1663 0         0 $char[$i] = CORE::chr hex $1;
1664             }
1665             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1666 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1667             }
1668             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1669 0         0 $char[$i] = {
1670             '\0' => "\0",
1671             '\n' => "\n",
1672             '\r' => "\r",
1673             '\t' => "\t",
1674             '\f' => "\f",
1675             '\b' => "\x08", # \b means backspace in character class
1676             '\a' => "\a",
1677             '\e' => "\e",
1678             '\d' => '[0-9]',
1679              
1680             # Vertical tabs are now whitespace
1681             # \s in a regex now matches a vertical tab in all circumstances.
1682             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1683             # \t \n \v \f \r space
1684             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1685             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1686             '\s' => '\s',
1687              
1688             '\w' => '[0-9A-Z_a-z]',
1689             '\D' => '${Char::Elatin10::eD}',
1690             '\S' => '${Char::Elatin10::eS}',
1691             '\W' => '${Char::Elatin10::eW}',
1692              
1693             '\H' => '${Char::Elatin10::eH}',
1694             '\V' => '${Char::Elatin10::eV}',
1695             '\h' => '[\x09\x20]',
1696             '\v' => '[\x0A\x0B\x0C\x0D]',
1697             '\R' => '${Char::Elatin10::eR}',
1698              
1699             }->{$1};
1700             }
1701              
1702             # POSIX-style character classes
1703             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1704 0         0 $char[$i] = {
1705              
1706             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1707             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1708             '[:^lower:]' => '${Char::Elatin10::not_lower_i}',
1709             '[:^upper:]' => '${Char::Elatin10::not_upper_i}',
1710              
1711             }->{$1};
1712             }
1713             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1714 0         0 $char[$i] = {
1715              
1716             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1717             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1718             '[:ascii:]' => '[\x00-\x7F]',
1719             '[:blank:]' => '[\x09\x20]',
1720             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1721             '[:digit:]' => '[\x30-\x39]',
1722             '[:graph:]' => '[\x21-\x7F]',
1723             '[:lower:]' => '[\x61-\x7A]',
1724             '[:print:]' => '[\x20-\x7F]',
1725             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1726              
1727             # P.174 POSIX-Style Character Classes
1728             # in Chapter 5: Pattern Matching
1729             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1730              
1731             # P.311 11.2.4 Character Classes and other Special Escapes
1732             # in Chapter 11: perlre: Perl regular expressions
1733             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1734              
1735             # P.210 POSIX-Style Character Classes
1736             # in Chapter 5: Pattern Matching
1737             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1738              
1739             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1740              
1741             '[:upper:]' => '[\x41-\x5A]',
1742             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1743             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1744             '[:^alnum:]' => '${Char::Elatin10::not_alnum}',
1745             '[:^alpha:]' => '${Char::Elatin10::not_alpha}',
1746             '[:^ascii:]' => '${Char::Elatin10::not_ascii}',
1747             '[:^blank:]' => '${Char::Elatin10::not_blank}',
1748             '[:^cntrl:]' => '${Char::Elatin10::not_cntrl}',
1749             '[:^digit:]' => '${Char::Elatin10::not_digit}',
1750             '[:^graph:]' => '${Char::Elatin10::not_graph}',
1751             '[:^lower:]' => '${Char::Elatin10::not_lower}',
1752             '[:^print:]' => '${Char::Elatin10::not_print}',
1753             '[:^punct:]' => '${Char::Elatin10::not_punct}',
1754             '[:^space:]' => '${Char::Elatin10::not_space}',
1755             '[:^upper:]' => '${Char::Elatin10::not_upper}',
1756             '[:^word:]' => '${Char::Elatin10::not_word}',
1757             '[:^xdigit:]' => '${Char::Elatin10::not_xdigit}',
1758              
1759             }->{$1};
1760             }
1761             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1762 0         0 $char[$i] = $1;
1763             }
1764             }
1765              
1766             # open character list
1767 0         0 my @singleoctet = ();
1768 0         0 my @multipleoctet = ();
1769 0         0 for (my $i=0; $i <= $#char; ) {
1770              
1771             # escaped -
1772 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1773 0         0 $i += 1;
1774 0         0 next;
1775             }
1776              
1777             # make range regexp
1778             elsif ($char[$i] eq '...') {
1779              
1780             # range error
1781 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1782 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1783             }
1784             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1785 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1786 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]);
1787             }
1788             }
1789              
1790             # make range regexp per length
1791 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1792 0         0 my @regexp = ();
1793              
1794             # is first and last
1795 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1796 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1797             }
1798              
1799             # is first
1800             elsif ($length == CORE::length($char[$i-1])) {
1801 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1802             }
1803              
1804             # is inside in first and last
1805             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1806 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1807             }
1808              
1809             # is last
1810             elsif ($length == CORE::length($char[$i+1])) {
1811 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1812             }
1813              
1814             else {
1815 0         0 die __FILE__, ": subroutine make_regexp panic.";
1816             }
1817              
1818 0 0       0 if ($length == 1) {
1819 0         0 push @singleoctet, @regexp;
1820             }
1821             else {
1822 0         0 push @multipleoctet, @regexp;
1823             }
1824             }
1825              
1826 0         0 $i += 2;
1827             }
1828              
1829             # with /i modifier
1830             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1831 0 0       0 if ($modifier =~ /i/oxms) {
1832 0         0 my $uc = Char::Elatin10::uc($char[$i]);
1833 0         0 my $fc = Char::Elatin10::fc($char[$i]);
1834 0 0       0 if ($uc ne $fc) {
1835 0 0       0 if (CORE::length($fc) == 1) {
1836 0         0 push @singleoctet, $uc, $fc;
1837             }
1838             else {
1839 0         0 push @singleoctet, $uc;
1840 0         0 push @multipleoctet, $fc;
1841             }
1842             }
1843             else {
1844 0         0 push @singleoctet, $char[$i];
1845             }
1846             }
1847             else {
1848 0         0 push @singleoctet, $char[$i];
1849             }
1850 0         0 $i += 1;
1851             }
1852              
1853             # single character of single octet code
1854             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1855 0         0 push @singleoctet, "\t", "\x20";
1856 0         0 $i += 1;
1857             }
1858             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1859 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1860 0         0 $i += 1;
1861             }
1862             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1863 0         0 push @singleoctet, $char[$i];
1864 0         0 $i += 1;
1865             }
1866              
1867             # single character of multiple-octet code
1868             else {
1869 0         0 push @multipleoctet, $char[$i];
1870 0         0 $i += 1;
1871             }
1872             }
1873              
1874             # quote metachar
1875 0         0 for (@singleoctet) {
1876 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1877 0         0 $_ = '-';
1878             }
1879             elsif (/\A \n \z/oxms) {
1880 0         0 $_ = '\n';
1881             }
1882             elsif (/\A \r \z/oxms) {
1883 0         0 $_ = '\r';
1884             }
1885             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1886 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1887             }
1888             elsif (/\A [\x00-\xFF] \z/oxms) {
1889 0         0 $_ = quotemeta $_;
1890             }
1891             }
1892              
1893             # return character list
1894 0         0 return \@singleoctet, \@multipleoctet;
1895             }
1896              
1897             #
1898             # Latin-10 octal escape sequence
1899             #
1900             sub octchr {
1901 0     0 0 0 my($octdigit) = @_;
1902              
1903 0         0 my @binary = ();
1904 0         0 for my $octal (split(//,$octdigit)) {
1905 0         0 push @binary, {
1906             '0' => '000',
1907             '1' => '001',
1908             '2' => '010',
1909             '3' => '011',
1910             '4' => '100',
1911             '5' => '101',
1912             '6' => '110',
1913             '7' => '111',
1914             }->{$octal};
1915             }
1916 0         0 my $binary = join '', @binary;
1917              
1918 0         0 my $octchr = {
1919             # 1234567
1920             1 => pack('B*', "0000000$binary"),
1921             2 => pack('B*', "000000$binary"),
1922             3 => pack('B*', "00000$binary"),
1923             4 => pack('B*', "0000$binary"),
1924             5 => pack('B*', "000$binary"),
1925             6 => pack('B*', "00$binary"),
1926             7 => pack('B*', "0$binary"),
1927             0 => pack('B*', "$binary"),
1928              
1929             }->{CORE::length($binary) % 8};
1930              
1931 0         0 return $octchr;
1932             }
1933              
1934             #
1935             # Latin-10 hexadecimal escape sequence
1936             #
1937             sub hexchr {
1938 0     0 0 0 my($hexdigit) = @_;
1939              
1940 0         0 my $hexchr = {
1941             1 => pack('H*', "0$hexdigit"),
1942             0 => pack('H*', "$hexdigit"),
1943              
1944             }->{CORE::length($_[0]) % 2};
1945              
1946 0         0 return $hexchr;
1947             }
1948              
1949             #
1950             # Latin-10 open character list for qr
1951             #
1952             sub charlist_qr {
1953              
1954 0     0 0 0 my $modifier = pop @_;
1955 0         0 my @char = @_;
1956              
1957 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1958 0         0 my @singleoctet = @$singleoctet;
1959 0         0 my @multipleoctet = @$multipleoctet;
1960              
1961             # return character list
1962 0 0       0 if (scalar(@singleoctet) >= 1) {
1963              
1964             # with /i modifier
1965 0 0       0 if ($modifier =~ m/i/oxms) {
1966 0         0 my %singleoctet_ignorecase = ();
1967 0         0 for (@singleoctet) {
1968 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1969 0         0 for my $ord (hex($1) .. hex($2)) {
1970 0         0 my $char = CORE::chr($ord);
1971 0         0 my $uc = Char::Elatin10::uc($char);
1972 0         0 my $fc = Char::Elatin10::fc($char);
1973 0 0       0 if ($uc eq $fc) {
1974 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1975             }
1976             else {
1977 0 0       0 if (CORE::length($fc) == 1) {
1978 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1979 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1980             }
1981             else {
1982 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1983 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1984             }
1985             }
1986             }
1987             }
1988 0 0       0 if ($_ ne '') {
1989 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1990             }
1991             }
1992 0         0 my $i = 0;
1993 0         0 my @singleoctet_ignorecase = ();
1994 0         0 for my $ord (0 .. 255) {
1995 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1996 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1997             }
1998             else {
1999 0         0 $i++;
2000             }
2001             }
2002 0         0 @singleoctet = ();
2003 0         0 for my $range (@singleoctet_ignorecase) {
2004 0 0       0 if (ref $range) {
2005 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2006 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2007             }
2008             elsif (scalar(@{$range}) == 2) {
2009 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2010             }
2011             else {
2012 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2013             }
2014             }
2015             }
2016             }
2017              
2018 0         0 my $not_anchor = '';
2019              
2020 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2021             }
2022 0 0       0 if (scalar(@multipleoctet) >= 2) {
2023 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2024             }
2025             else {
2026 0         0 return $multipleoctet[0];
2027             }
2028             }
2029              
2030             #
2031             # Latin-10 open character list for not qr
2032             #
2033             sub charlist_not_qr {
2034              
2035 0     0 0 0 my $modifier = pop @_;
2036 0         0 my @char = @_;
2037              
2038 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2039 0         0 my @singleoctet = @$singleoctet;
2040 0         0 my @multipleoctet = @$multipleoctet;
2041              
2042             # with /i modifier
2043 0 0       0 if ($modifier =~ m/i/oxms) {
2044 0         0 my %singleoctet_ignorecase = ();
2045 0         0 for (@singleoctet) {
2046 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2047 0         0 for my $ord (hex($1) .. hex($2)) {
2048 0         0 my $char = CORE::chr($ord);
2049 0         0 my $uc = Char::Elatin10::uc($char);
2050 0         0 my $fc = Char::Elatin10::fc($char);
2051 0 0       0 if ($uc eq $fc) {
2052 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2053             }
2054             else {
2055 0 0       0 if (CORE::length($fc) == 1) {
2056 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2057 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2058             }
2059             else {
2060 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2061 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2062             }
2063             }
2064             }
2065             }
2066 0 0       0 if ($_ ne '') {
2067 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2068             }
2069             }
2070 0         0 my $i = 0;
2071 0         0 my @singleoctet_ignorecase = ();
2072 0         0 for my $ord (0 .. 255) {
2073 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2074 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2075             }
2076             else {
2077 0         0 $i++;
2078             }
2079             }
2080 0         0 @singleoctet = ();
2081 0         0 for my $range (@singleoctet_ignorecase) {
2082 0 0       0 if (ref $range) {
2083 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2084 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2085             }
2086             elsif (scalar(@{$range}) == 2) {
2087 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2088             }
2089             else {
2090 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2091             }
2092             }
2093             }
2094             }
2095              
2096             # return character list
2097 0 0       0 if (scalar(@multipleoctet) >= 1) {
2098 0 0       0 if (scalar(@singleoctet) >= 1) {
2099              
2100             # any character other than multiple-octet and single octet character class
2101 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2102             }
2103             else {
2104              
2105             # any character other than multiple-octet character class
2106 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2107             }
2108             }
2109             else {
2110 0 0       0 if (scalar(@singleoctet) >= 1) {
2111              
2112             # any character other than single octet character class
2113 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2114             }
2115             else {
2116              
2117             # any character
2118 0         0 return "(?:$your_char)";
2119             }
2120             }
2121             }
2122              
2123             #
2124             # open file in read mode
2125             #
2126             sub _open_r {
2127 197     197   750 my(undef,$file) = @_;
2128 197         829 $file =~ s#\A (\s) #./$1#oxms;
2129 197   33     23737 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2130             open($_[0],"< $file\0");
2131             }
2132              
2133             #
2134             # open file in write mode
2135             #
2136             sub _open_w {
2137 0     0   0 my(undef,$file) = @_;
2138 0         0 $file =~ s#\A (\s) #./$1#oxms;
2139 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2140             open($_[0],"> $file\0");
2141             }
2142              
2143             #
2144             # open file in append mode
2145             #
2146             sub _open_a {
2147 0     0   0 my(undef,$file) = @_;
2148 0         0 $file =~ s#\A (\s) #./$1#oxms;
2149 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2150             open($_[0],">> $file\0");
2151             }
2152              
2153             #
2154             # safe system
2155             #
2156             sub _systemx {
2157              
2158             # P.707 29.2.33. exec
2159             # in Chapter 29: Functions
2160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2161             #
2162             # Be aware that in older releases of Perl, exec (and system) did not flush
2163             # your output buffer, so you needed to enable command buffering by setting $|
2164             # on one or more filehandles to avoid lost output in the case of exec, or
2165             # misordererd output in the case of system. This situation was largely remedied
2166             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2167              
2168             # P.855 exec
2169             # in Chapter 27: Functions
2170             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2171             #
2172             # In very old release of Perl (before v5.6), exec (and system) did not flush
2173             # your output buffer, so you needed to enable command buffering by setting $|
2174             # on one or more filehandles to avoid lost output with exec or misordered
2175             # output with system.
2176              
2177 197     197   708 $| = 1;
2178              
2179             # P.565 23.1.2. Cleaning Up Your Environment
2180             # in Chapter 23: Security
2181             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2182              
2183             # P.656 Cleaning Up Your Environment
2184             # in Chapter 20: Security
2185             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2186              
2187             # local $ENV{'PATH'} = '.';
2188 197         2028 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2189              
2190             # P.707 29.2.33. exec
2191             # in Chapter 29: Functions
2192             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2193             #
2194             # As we mentioned earlier, exec treats a discrete list of arguments as an
2195             # indication that it should bypass shell processing. However, there is one
2196             # place where you might still get tripped up. The exec call (and system, too)
2197             # will not distinguish between a single scalar argument and an array containing
2198             # only one element.
2199             #
2200             # @args = ("echo surprise"); # just one element in list
2201             # exec @args # still subject to shell escapes
2202             # or die "exec: $!"; # because @args == 1
2203             #
2204             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2205             # first argument as the pathname, which forces the rest of the arguments to be
2206             # interpreted as a list, even if there is only one of them:
2207             #
2208             # exec { $args[0] } @args # safe even with one-argument list
2209             # or die "can't exec @args: $!";
2210              
2211             # P.855 exec
2212             # in Chapter 27: Functions
2213             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2214             #
2215             # As we mentioned earlier, exec treats a discrete list of arguments as a
2216             # directive to bypass shell processing. However, there is one place where
2217             # you might still get tripped up. The exec call (and system, too) cannot
2218             # distinguish between a single scalar argument and an array containing
2219             # only one element.
2220             #
2221             # @args = ("echo surprise"); # just one element in list
2222             # exec @args # still subject to shell escapes
2223             # || die "exec: $!"; # because @args == 1
2224             #
2225             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2226             # argument as the pathname, which forces the rest of the arguments to be
2227             # interpreted as a list, even if there is only one of them:
2228             #
2229             # exec { $args[0] } @args # safe even with one-argument list
2230             # || die "can't exec @args: $!";
2231              
2232 197         402 return CORE::system { $_[0] } @_; # safe even with one-argument list
  197         24005799  
2233             }
2234              
2235             #
2236             # Latin-10 order to character (with parameter)
2237             #
2238             sub Char::Elatin10::chr(;$) {
2239              
2240 0 0   0 0   my $c = @_ ? $_[0] : $_;
2241              
2242 0 0         if ($c == 0x00) {
2243 0           return "\x00";
2244             }
2245             else {
2246 0           my @chr = ();
2247 0           while ($c > 0) {
2248 0           unshift @chr, ($c % 0x100);
2249 0           $c = int($c / 0x100);
2250             }
2251 0           return pack 'C*', @chr;
2252             }
2253             }
2254              
2255             #
2256             # Latin-10 order to character (without parameter)
2257             #
2258             sub Char::Elatin10::chr_() {
2259              
2260 0     0 0   my $c = $_;
2261              
2262 0 0         if ($c == 0x00) {
2263 0           return "\x00";
2264             }
2265             else {
2266 0           my @chr = ();
2267 0           while ($c > 0) {
2268 0           unshift @chr, ($c % 0x100);
2269 0           $c = int($c / 0x100);
2270             }
2271 0           return pack 'C*', @chr;
2272             }
2273             }
2274              
2275             #
2276             # Latin-10 path globbing (with parameter)
2277             #
2278             sub Char::Elatin10::glob($) {
2279              
2280 0 0   0 0   if (wantarray) {
2281 0           my @glob = _DOS_like_glob(@_);
2282 0           for my $glob (@glob) {
2283 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2284             }
2285 0           return @glob;
2286             }
2287             else {
2288 0           my $glob = _DOS_like_glob(@_);
2289 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2290 0           return $glob;
2291             }
2292             }
2293              
2294             #
2295             # Latin-10 path globbing (without parameter)
2296             #
2297             sub Char::Elatin10::glob_() {
2298              
2299 0 0   0 0   if (wantarray) {
2300 0           my @glob = _DOS_like_glob();
2301 0           for my $glob (@glob) {
2302 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2303             }
2304 0           return @glob;
2305             }
2306             else {
2307 0           my $glob = _DOS_like_glob();
2308 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2309 0           return $glob;
2310             }
2311             }
2312              
2313             #
2314             # Latin-10 path globbing via File::DosGlob 1.10
2315             #
2316             # Often I confuse "_dosglob" and "_doglob".
2317             # So, I renamed "_dosglob" to "_DOS_like_glob".
2318             #
2319             my %iter;
2320             my %entries;
2321             sub _DOS_like_glob {
2322              
2323             # context (keyed by second cxix argument provided by core)
2324 0     0     my($expr,$cxix) = @_;
2325              
2326             # glob without args defaults to $_
2327 0 0         $expr = $_ if not defined $expr;
2328              
2329             # represents the current user's home directory
2330             #
2331             # 7.3. Expanding Tildes in Filenames
2332             # in Chapter 7. File Access
2333             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2334             #
2335             # and File::HomeDir, File::HomeDir::Windows module
2336              
2337             # DOS-like system
2338 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2339 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2340 0           { my_home_MSWin32() }oxmse;
2341             }
2342              
2343             # UNIX-like system
2344             else {
2345 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2346 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2347             }
2348              
2349             # assume global context if not provided one
2350 0 0         $cxix = '_G_' if not defined $cxix;
2351 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2352              
2353             # if we're just beginning, do it all first
2354 0 0         if ($iter{$cxix} == 0) {
2355 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2356             }
2357              
2358             # chuck it all out, quick or slow
2359 0 0         if (wantarray) {
2360 0           delete $iter{$cxix};
2361 0           return @{delete $entries{$cxix}};
  0            
2362             }
2363             else {
2364 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2365 0           return shift @{$entries{$cxix}};
  0            
2366             }
2367             else {
2368             # return undef for EOL
2369 0           delete $iter{$cxix};
2370 0           delete $entries{$cxix};
2371 0           return undef;
2372             }
2373             }
2374             }
2375              
2376             #
2377             # Latin-10 path globbing subroutine
2378             #
2379             sub _do_glob {
2380              
2381 0     0     my($cond,@expr) = @_;
2382 0           my @glob = ();
2383 0           my $fix_drive_relative_paths = 0;
2384              
2385             OUTER:
2386 0           for my $expr (@expr) {
2387 0 0         next OUTER if not defined $expr;
2388 0 0         next OUTER if $expr eq '';
2389              
2390 0           my @matched = ();
2391 0           my @globdir = ();
2392 0           my $head = '.';
2393 0           my $pathsep = '/';
2394 0           my $tail;
2395              
2396             # if argument is within quotes strip em and do no globbing
2397 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2398 0           $expr = $1;
2399 0 0         if ($cond eq 'd') {
2400 0 0         if (-d $expr) {
2401 0           push @glob, $expr;
2402             }
2403             }
2404             else {
2405 0 0         if (-e $expr) {
2406 0           push @glob, $expr;
2407             }
2408             }
2409 0           next OUTER;
2410             }
2411              
2412             # wildcards with a drive prefix such as h:*.pm must be changed
2413             # to h:./*.pm to expand correctly
2414 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2415 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2416 0           $fix_drive_relative_paths = 1;
2417             }
2418             }
2419              
2420 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2421 0 0         if ($tail eq '') {
2422 0           push @glob, $expr;
2423 0           next OUTER;
2424             }
2425 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2426 0 0         if (@globdir = _do_glob('d', $head)) {
2427 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2428 0           next OUTER;
2429             }
2430             }
2431 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2432 0           $head .= $pathsep;
2433             }
2434 0           $expr = $tail;
2435             }
2436              
2437             # If file component has no wildcards, we can avoid opendir
2438 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2439 0 0         if ($head eq '.') {
2440 0           $head = '';
2441             }
2442 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2443 0           $head .= $pathsep;
2444             }
2445 0           $head .= $expr;
2446 0 0         if ($cond eq 'd') {
2447 0 0         if (-d $head) {
2448 0           push @glob, $head;
2449             }
2450             }
2451             else {
2452 0 0         if (-e $head) {
2453 0           push @glob, $head;
2454             }
2455             }
2456 0           next OUTER;
2457             }
2458 0 0         opendir(*DIR, $head) or next OUTER;
2459 0           my @leaf = readdir DIR;
2460 0           closedir DIR;
2461              
2462 0 0         if ($head eq '.') {
2463 0           $head = '';
2464             }
2465 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2466 0           $head .= $pathsep;
2467             }
2468              
2469 0           my $pattern = '';
2470 0           while ($expr =~ / \G ($q_char) /oxgc) {
2471 0           my $char = $1;
2472              
2473             # 6.9. Matching Shell Globs as Regular Expressions
2474             # in Chapter 6. Pattern Matching
2475             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2476             # (and so on)
2477              
2478 0 0         if ($char eq '*') {
    0          
    0          
2479 0           $pattern .= "(?:$your_char)*",
2480             }
2481             elsif ($char eq '?') {
2482 0           $pattern .= "(?:$your_char)?", # DOS style
2483             # $pattern .= "(?:$your_char)", # UNIX style
2484             }
2485             elsif ((my $fc = Char::Elatin10::fc($char)) ne $char) {
2486 0           $pattern .= $fc;
2487             }
2488             else {
2489 0           $pattern .= quotemeta $char;
2490             }
2491             }
2492 0     0     my $matchsub = sub { Char::Elatin10::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2493              
2494             # if ($@) {
2495             # print STDERR "$0: $@\n";
2496             # next OUTER;
2497             # }
2498              
2499             INNER:
2500 0           for my $leaf (@leaf) {
2501 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2502 0           next INNER;
2503             }
2504 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2505 0           next INNER;
2506             }
2507              
2508 0 0         if (&$matchsub($leaf)) {
2509 0           push @matched, "$head$leaf";
2510 0           next INNER;
2511             }
2512              
2513             # [DOS compatibility special case]
2514             # Failed, add a trailing dot and try again, but only...
2515              
2516 0 0 0       if (Char::Elatin10::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2517             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2518             Char::Elatin10::index($pattern,'\\.') != -1 # pattern has a dot.
2519             ) {
2520 0 0         if (&$matchsub("$leaf.")) {
2521 0           push @matched, "$head$leaf";
2522 0           next INNER;
2523             }
2524             }
2525             }
2526 0 0         if (@matched) {
2527 0           push @glob, @matched;
2528             }
2529             }
2530 0 0         if ($fix_drive_relative_paths) {
2531 0           for my $glob (@glob) {
2532 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2533             }
2534             }
2535 0           return @glob;
2536             }
2537              
2538             #
2539             # Latin-10 parse line
2540             #
2541             sub _parse_line {
2542              
2543 0     0     my($line) = @_;
2544              
2545 0           $line .= ' ';
2546 0           my @piece = ();
2547 0           while ($line =~ /
2548             " ( (?: [^"] )* ) " \s+ |
2549             ( (?: [^"\s] )* ) \s+
2550             /oxmsg
2551             ) {
2552 0 0         push @piece, defined($1) ? $1 : $2;
2553             }
2554 0           return @piece;
2555             }
2556              
2557             #
2558             # Latin-10 parse path
2559             #
2560             sub _parse_path {
2561              
2562 0     0     my($path,$pathsep) = @_;
2563              
2564 0           $path .= '/';
2565 0           my @subpath = ();
2566 0           while ($path =~ /
2567             ((?: [^\/\\] )+?) [\/\\]
2568             /oxmsg
2569             ) {
2570 0           push @subpath, $1;
2571             }
2572              
2573 0           my $tail = pop @subpath;
2574 0           my $head = join $pathsep, @subpath;
2575 0           return $head, $tail;
2576             }
2577              
2578             #
2579             # via File::HomeDir::Windows 1.00
2580             #
2581             sub my_home_MSWin32 {
2582              
2583             # A lot of unix people and unix-derived tools rely on
2584             # the ability to overload HOME. We will support it too
2585             # so that they can replace raw HOME calls with File::HomeDir.
2586 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2587 0           return $ENV{'HOME'};
2588             }
2589              
2590             # Do we have a user profile?
2591             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2592 0           return $ENV{'USERPROFILE'};
2593             }
2594              
2595             # Some Windows use something like $ENV{'HOME'}
2596             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2597 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2598             }
2599              
2600 0           return undef;
2601             }
2602              
2603             #
2604             # via File::HomeDir::Unix 1.00
2605             #
2606             sub my_home {
2607 0     0 0   my $home;
2608              
2609 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2610 0           $home = $ENV{'HOME'};
2611             }
2612              
2613             # This is from the original code, but I'm guessing
2614             # it means "login directory" and exists on some Unixes.
2615             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2616 0           $home = $ENV{'LOGDIR'};
2617             }
2618              
2619             ### More-desperate methods
2620              
2621             # Light desperation on any (Unixish) platform
2622             else {
2623 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2624             }
2625              
2626             # On Unix in general, a non-existant home means "no home"
2627             # For example, "nobody"-like users might use /nonexistant
2628 0 0 0       if (defined $home and ! -d($home)) {
2629 0           $home = undef;
2630             }
2631 0           return $home;
2632             }
2633              
2634             #
2635             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2636             #
2637             sub Char::Elatin10::PREMATCH {
2638 0     0 0   return $`;
2639             }
2640              
2641             #
2642             # ${^MATCH}, $MATCH, $& the string that matched
2643             #
2644             sub Char::Elatin10::MATCH {
2645 0     0 0   return $&;
2646             }
2647              
2648             #
2649             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2650             #
2651             sub Char::Elatin10::POSTMATCH {
2652 0     0 0   return $';
2653             }
2654              
2655             #
2656             # Latin-10 character to order (with parameter)
2657             #
2658             sub Char::Latin10::ord(;$) {
2659              
2660 0 0   0 1   local $_ = shift if @_;
2661              
2662 0 0         if (/\A ($q_char) /oxms) {
2663 0           my @ord = unpack 'C*', $1;
2664 0           my $ord = 0;
2665 0           while (my $o = shift @ord) {
2666 0           $ord = $ord * 0x100 + $o;
2667             }
2668 0           return $ord;
2669             }
2670             else {
2671 0           return CORE::ord $_;
2672             }
2673             }
2674              
2675             #
2676             # Latin-10 character to order (without parameter)
2677             #
2678             sub Char::Latin10::ord_() {
2679              
2680 0 0   0 0   if (/\A ($q_char) /oxms) {
2681 0           my @ord = unpack 'C*', $1;
2682 0           my $ord = 0;
2683 0           while (my $o = shift @ord) {
2684 0           $ord = $ord * 0x100 + $o;
2685             }
2686 0           return $ord;
2687             }
2688             else {
2689 0           return CORE::ord $_;
2690             }
2691             }
2692              
2693             #
2694             # Latin-10 reverse
2695             #
2696             sub Char::Latin10::reverse(@) {
2697              
2698 0 0   0 0   if (wantarray) {
2699 0           return CORE::reverse @_;
2700             }
2701             else {
2702              
2703             # One of us once cornered Larry in an elevator and asked him what
2704             # problem he was solving with this, but he looked as far off into
2705             # the distance as he could in an elevator and said, "It seemed like
2706             # a good idea at the time."
2707              
2708 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2709             }
2710             }
2711              
2712             #
2713             # Latin-10 getc (with parameter, without parameter)
2714             #
2715             sub Char::Latin10::getc(;*@) {
2716              
2717 0     0 0   my($package) = caller;
2718 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2719 0 0 0       croak 'Too many arguments for Char::Latin10::getc' if @_ and not wantarray;
2720              
2721 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2722 0           my $getc = '';
2723 0           for my $length ($length[0] .. $length[-1]) {
2724 0           $getc .= CORE::getc($fh);
2725 0 0         if (exists $range_tr{CORE::length($getc)}) {
2726 0 0         if ($getc =~ /\A ${Char::Elatin10::dot_s} \z/oxms) {
2727 0 0         return wantarray ? ($getc,@_) : $getc;
2728             }
2729             }
2730             }
2731 0 0         return wantarray ? ($getc,@_) : $getc;
2732             }
2733              
2734             #
2735             # Latin-10 length by character
2736             #
2737             sub Char::Latin10::length(;$) {
2738              
2739 0 0   0 1   local $_ = shift if @_;
2740              
2741 0           local @_ = /\G ($q_char) /oxmsg;
2742 0           return scalar @_;
2743             }
2744              
2745             #
2746             # Latin-10 substr by character
2747             #
2748             BEGIN {
2749              
2750             # P.232 The lvalue Attribute
2751             # in Chapter 6: Subroutines
2752             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2753              
2754             # P.336 The lvalue Attribute
2755             # in Chapter 7: Subroutines
2756             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2757              
2758             # P.144 8.4 Lvalue subroutines
2759             # in Chapter 8: perlsub: Perl subroutines
2760             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2761              
2762 197 50 0 197 1 160473 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            
2763             # vv----------------*******
2764             sub Char::Latin10::substr($$;$$) %s {
2765              
2766             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2767              
2768             # If the substring is beyond either end of the string, substr() returns the undefined
2769             # value and produces a warning. When used as an lvalue, specifying a substring that
2770             # is entirely outside the string raises an exception.
2771             # http://perldoc.perl.org/functions/substr.html
2772              
2773             # A return with no argument returns the scalar value undef in scalar context,
2774             # an empty list () in list context, and (naturally) nothing at all in void
2775             # context.
2776              
2777             my $offset = $_[1];
2778             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2779             return;
2780             }
2781              
2782             # substr($string,$offset,$length,$replacement)
2783             if (@_ == 4) {
2784             my(undef,undef,$length,$replacement) = @_;
2785             my $substr = join '', splice(@char, $offset, $length, $replacement);
2786             $_[0] = join '', @char;
2787              
2788             # return $substr; this doesn't work, don't say "return"
2789             $substr;
2790             }
2791              
2792             # substr($string,$offset,$length)
2793             elsif (@_ == 3) {
2794             my(undef,undef,$length) = @_;
2795             my $octet_offset = 0;
2796             my $octet_length = 0;
2797             if ($offset == 0) {
2798             $octet_offset = 0;
2799             }
2800             elsif ($offset > 0) {
2801             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2802             }
2803             else {
2804             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2805             }
2806             if ($length == 0) {
2807             $octet_length = 0;
2808             }
2809             elsif ($length > 0) {
2810             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2811             }
2812             else {
2813             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2814             }
2815             CORE::substr($_[0], $octet_offset, $octet_length);
2816             }
2817              
2818             # substr($string,$offset)
2819             else {
2820             my $octet_offset = 0;
2821             if ($offset == 0) {
2822             $octet_offset = 0;
2823             }
2824             elsif ($offset > 0) {
2825             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2826             }
2827             else {
2828             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2829             }
2830             CORE::substr($_[0], $octet_offset);
2831             }
2832             }
2833             END
2834             }
2835              
2836             #
2837             # Latin-10 index by character
2838             #
2839             sub Char::Latin10::index($$;$) {
2840              
2841 0     0 1   my $index;
2842 0 0         if (@_ == 3) {
2843 0           $index = Char::Elatin10::index($_[0], $_[1], CORE::length(Char::Latin10::substr($_[0], 0, $_[2])));
2844             }
2845             else {
2846 0           $index = Char::Elatin10::index($_[0], $_[1]);
2847             }
2848              
2849 0 0         if ($index == -1) {
2850 0           return -1;
2851             }
2852             else {
2853 0           return Char::Latin10::length(CORE::substr $_[0], 0, $index);
2854             }
2855             }
2856              
2857             #
2858             # Latin-10 rindex by character
2859             #
2860             sub Char::Latin10::rindex($$;$) {
2861              
2862 0     0 1   my $rindex;
2863 0 0         if (@_ == 3) {
2864 0           $rindex = Char::Elatin10::rindex($_[0], $_[1], CORE::length(Char::Latin10::substr($_[0], 0, $_[2])));
2865             }
2866             else {
2867 0           $rindex = Char::Elatin10::rindex($_[0], $_[1]);
2868             }
2869              
2870 0 0         if ($rindex == -1) {
2871 0           return -1;
2872             }
2873             else {
2874 0           return Char::Latin10::length(CORE::substr $_[0], 0, $rindex);
2875             }
2876             }
2877              
2878             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2879             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2880 197     197   21230 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  197     197   2022  
  197         389  
  197         16067  
2881              
2882             # ord() to ord() or Char::Latin10::ord()
2883 197     197   11910 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  197     197   1145  
  197         391  
  197         14034  
2884              
2885             # ord to ord or Char::Latin10::ord_
2886 197     197   11924 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  197     197   1092  
  197         387  
  197         12182  
2887              
2888             # reverse to reverse or Char::Latin10::reverse
2889 197     197   11936 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  197     197   1121  
  197         378  
  197         13264  
2890              
2891             # getc to getc or Char::Latin10::getc
2892 197     197   11863 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  197     197   2520  
  197         464  
  197         14554  
2893              
2894             # P.1023 Appendix W.9 Multibyte Anchoring
2895             # of ISBN 1-56592-224-7 CJKV Information Processing
2896              
2897             my $anchor = '';
2898              
2899 197     197   13049 BEGIN { CORE::eval q{ use vars qw($nest) } }
  197     197   1236  
  197         346  
  197         12422768  
2900              
2901             # regexp of nested parens in qqXX
2902              
2903             # P.340 Matching Nested Constructs with Embedded Code
2904             # in Chapter 7: Perl
2905             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2906              
2907             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2908             \\c[\x40-\x5F] |
2909             \\ [\x00-\xFF] |
2910             [^()] |
2911             \( (?{$nest++}) |
2912             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2913             }xms;
2914             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2915             \\c[\x40-\x5F] |
2916             \\ [\x00-\xFF] |
2917             [^{}] |
2918             \{ (?{$nest++}) |
2919             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2920             }xms;
2921             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2922             \\c[\x40-\x5F] |
2923             \\ [\x00-\xFF] |
2924             [^[\]] |
2925             \[ (?{$nest++}) |
2926             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2927             }xms;
2928             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2929             \\c[\x40-\x5F] |
2930             \\ [\x00-\xFF] |
2931             [^<>] |
2932             \< (?{$nest++}) |
2933             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2934             }xms;
2935             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2936             (?: ::)? (?:
2937             [a-zA-Z_][a-zA-Z_0-9]*
2938             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2939             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2940             ))
2941             }xms;
2942             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2943             (?: ::)? (?:
2944             [0-9]+ |
2945             [^a-zA-Z_0-9\[\]] |
2946             ^[A-Z] |
2947             [a-zA-Z_][a-zA-Z_0-9]*
2948             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2949             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2950             ))
2951             }xms;
2952             my $qq_substr = qr{(?: Char::Latin10::substr | CORE::substr | substr ) \( $qq_paren \)
2953             }xms;
2954              
2955             # regexp of nested parens in qXX
2956             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2957             [^()] |
2958             \( (?{$nest++}) |
2959             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2960             }xms;
2961             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2962             [^{}] |
2963             \{ (?{$nest++}) |
2964             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2965             }xms;
2966             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2967             [^[\]] |
2968             \[ (?{$nest++}) |
2969             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2970             }xms;
2971             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2972             [^<>] |
2973             \< (?{$nest++}) |
2974             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2975             }xms;
2976              
2977             my $matched = '';
2978             my $s_matched = '';
2979              
2980             my $tr_variable = ''; # variable of tr///
2981             my $sub_variable = ''; # variable of s///
2982             my $bind_operator = ''; # =~ or !~
2983              
2984             my @heredoc = (); # here document
2985             my @heredoc_delimiter = ();
2986             my $here_script = ''; # here script
2987              
2988             #
2989             # escape Latin-10 script
2990             #
2991             sub Char::Latin10::escape(;$) {
2992 0 0   0 0   local($_) = $_[0] if @_;
2993              
2994             # P.359 The Study Function
2995             # in Chapter 7: Perl
2996             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2997              
2998 0           study $_; # Yes, I studied study yesterday.
2999              
3000             # while all script
3001              
3002             # 6.14. Matching from Where the Last Pattern Left Off
3003             # in Chapter 6. Pattern Matching
3004             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3005             # (and so on)
3006              
3007             # one member of Tag-team
3008             #
3009             # P.128 Start of match (or end of previous match): \G
3010             # P.130 Advanced Use of \G with Perl
3011             # in Chapter 3: Overview of Regular Expression Features and Flavors
3012             # P.255 Use leading anchors
3013             # P.256 Expose ^ and \G at the front expressions
3014             # in Chapter 6: Crafting an Efficient Expression
3015             # P.315 "Tag-team" matching with /gc
3016             # in Chapter 7: Perl
3017             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3018              
3019 0           my $e_script = '';
3020 0           while (not /\G \z/oxgc) { # member
3021 0           $e_script .= Char::Latin10::escape_token();
3022             }
3023              
3024 0           return $e_script;
3025             }
3026              
3027             #
3028             # escape Latin-10 token of script
3029             #
3030             sub Char::Latin10::escape_token {
3031              
3032             # \n output here document
3033              
3034 0     0 0   my $ignore_modules = join('|', qw(
3035             utf8
3036             bytes
3037             charnames
3038             I18N::Japanese
3039             I18N::Collate
3040             I18N::JExt
3041             File::DosGlob
3042             Wild
3043             Wildcard
3044             Japanese
3045             ));
3046              
3047             # another member of Tag-team
3048             #
3049             # P.315 "Tag-team" matching with /gc
3050             # in Chapter 7: Perl
3051             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3052              
3053 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          
3054 0           my $heredoc = '';
3055 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3056 0           $slash = 'm//';
3057              
3058 0           $heredoc = join '', @heredoc;
3059 0           @heredoc = ();
3060              
3061             # skip here document
3062 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3063 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3064             }
3065 0           @heredoc_delimiter = ();
3066              
3067 0           $here_script = '';
3068             }
3069 0           return "\n" . $heredoc;
3070             }
3071              
3072             # ignore space, comment
3073 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
3074              
3075             # if (, elsif (, unless (, while (, until (, given (, and when (
3076              
3077             # given, when
3078              
3079             # P.225 The given Statement
3080             # in Chapter 15: Smart Matching and given-when
3081             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3082              
3083             # P.133 The given Statement
3084             # in Chapter 4: Statements and Declarations
3085             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3086              
3087             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
3088 0           $slash = 'm//';
3089 0           return $1;
3090             }
3091              
3092             # scalar variable ($scalar = ...) =~ tr///;
3093             # scalar variable ($scalar = ...) =~ s///;
3094              
3095             # state
3096              
3097             # P.68 Persistent, Private Variables
3098             # in Chapter 4: Subroutines
3099             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3100              
3101             # P.160 Persistent Lexically Scoped Variables: state
3102             # in Chapter 4: Statements and Declarations
3103             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3104              
3105             # (and so on)
3106              
3107             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
3108 0           my $e_string = e_string($1);
3109              
3110 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3111 0           $tr_variable = $e_string . e_string($1);
3112 0           $bind_operator = $2;
3113 0           $slash = 'm//';
3114 0           return '';
3115             }
3116             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3117 0           $sub_variable = $e_string . e_string($1);
3118 0           $bind_operator = $2;
3119 0           $slash = 'm//';
3120 0           return '';
3121             }
3122             else {
3123 0           $slash = 'div';
3124 0           return $e_string;
3125             }
3126             }
3127              
3128             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin10::PREMATCH()
3129             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
3130 0           $slash = 'div';
3131 0           return q{Char::Elatin10::PREMATCH()};
3132             }
3133              
3134             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin10::MATCH()
3135             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
3136 0           $slash = 'div';
3137 0           return q{Char::Elatin10::MATCH()};
3138             }
3139              
3140             # $', ${'} --> $', ${'}
3141             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3142 0           $slash = 'div';
3143 0           return $1;
3144             }
3145              
3146             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin10::POSTMATCH()
3147             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
3148 0           $slash = 'div';
3149 0           return q{Char::Elatin10::POSTMATCH()};
3150             }
3151              
3152             # scalar variable $scalar =~ tr///;
3153             # scalar variable $scalar =~ s///;
3154             # substr() =~ tr///;
3155             # substr() =~ s///;
3156             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3157 0           my $scalar = e_string($1);
3158              
3159 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3160 0           $tr_variable = $scalar;
3161 0           $bind_operator = $1;
3162 0           $slash = 'm//';
3163 0           return '';
3164             }
3165             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3166 0           $sub_variable = $scalar;
3167 0           $bind_operator = $1;
3168 0           $slash = 'm//';
3169 0           return '';
3170             }
3171             else {
3172 0           $slash = 'div';
3173 0           return $scalar;
3174             }
3175             }
3176              
3177             # end of statement
3178             elsif (/\G ( [,;] ) /oxgc) {
3179 0           $slash = 'm//';
3180              
3181             # clear tr/// variable
3182 0           $tr_variable = '';
3183              
3184             # clear s/// variable
3185 0           $sub_variable = '';
3186              
3187 0           $bind_operator = '';
3188              
3189 0           return $1;
3190             }
3191              
3192             # bareword
3193             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
3194 0           return $1;
3195             }
3196              
3197             # $0 --> $0
3198             elsif (/\G ( \$ 0 ) /oxmsgc) {
3199 0           $slash = 'div';
3200 0           return $1;
3201             }
3202             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
3203 0           $slash = 'div';
3204 0           return $1;
3205             }
3206              
3207             # $$ --> $$
3208             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3209 0           $slash = 'div';
3210 0           return $1;
3211             }
3212              
3213             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3214             # $1, $2, $3 --> $1, $2, $3 otherwise
3215             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
3216 0           $slash = 'div';
3217 0           return e_capture($1);
3218             }
3219             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
3220 0           $slash = 'div';
3221 0           return e_capture($1);
3222             }
3223              
3224             # $$foo[ ... ] --> $ $foo->[ ... ]
3225             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
3226 0           $slash = 'div';
3227 0           return e_capture($1.'->'.$2);
3228             }
3229              
3230             # $$foo{ ... } --> $ $foo->{ ... }
3231             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
3232 0           $slash = 'div';
3233 0           return e_capture($1.'->'.$2);
3234             }
3235              
3236             # $$foo
3237             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
3238 0           $slash = 'div';
3239 0           return e_capture($1);
3240             }
3241              
3242             # ${ foo }
3243             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
3244 0           $slash = 'div';
3245 0           return '${' . $1 . '}';
3246             }
3247              
3248             # ${ ... }
3249             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
3250 0           $slash = 'div';
3251 0           return e_capture($1);
3252             }
3253              
3254             # variable or function
3255             # $ @ % & * $ #
3256             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) {
3257 0           $slash = 'div';
3258 0           return $1;
3259             }
3260             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3261             # $ @ # \ ' " / ? ( ) [ ] < >
3262             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3263 0           $slash = 'div';
3264 0           return $1;
3265             }
3266              
3267             # while ()
3268             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
3269 0           return $1;
3270             }
3271              
3272             # while () --- glob
3273              
3274             # avoid "Error: Runtime exception" of perl version 5.005_03
3275              
3276             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
3277 0           return 'while ($_ = Char::Elatin10::glob("' . $1 . '"))';
3278             }
3279              
3280             # while (glob)
3281             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
3282 0           return 'while ($_ = Char::Elatin10::glob_)';
3283             }
3284              
3285             # while (glob(WILDCARD))
3286             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
3287 0           return 'while ($_ = Char::Elatin10::glob';
3288             }
3289              
3290             # doit if, doit unless, doit while, doit until, doit for, doit when
3291 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3292              
3293             # subroutines of package Char::Elatin10
3294 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3295 0           elsif (/\G \b Char::Latin10::eval (?= \s* \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3296 0           elsif (/\G \b Char::Latin10::eval \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'eval Char::Latin10::escape'; }
  0            
3297 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3298 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::chop'; }
  0            
3299 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3300 0           elsif (/\G \b Char::Latin10::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin10::index'; }
  0            
3301 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::index'; }
  0            
3302 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3303 0           elsif (/\G \b Char::Latin10::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin10::rindex'; }
  0            
3304 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::rindex'; }
  0            
3305 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::lc'; }
  0            
3306 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::lcfirst'; }
  0            
3307 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::uc'; }
  0            
3308 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::ucfirst'; }
  0            
3309 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::fc'; }
  0            
3310              
3311             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3312 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3313 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3314 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3315 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3316 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3317 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3318 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3319              
3320 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3321 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3322 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3323 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3324 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3325 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3326 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3327              
3328             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3329 0           { $slash = 'm//'; return "-s $1"; }
  0            
3330 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3331 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3332 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3333              
3334 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3335 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3336 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::chr'; }
  0            
3337 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3338 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3339 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::glob'; }
  0            
3340 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::lc_'; }
  0            
3341 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::lcfirst_'; }
  0            
3342 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::uc_'; }
  0            
3343 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::ucfirst_'; }
  0            
3344 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::fc_'; }
  0            
3345 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3346              
3347 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3348 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3349 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::chr_'; }
  0            
3350 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3351 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3352 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin10::glob_'; }
  0            
3353 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3354 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3355             # split
3356             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
3357 0           $slash = 'm//';
3358              
3359 0           my $e = '';
3360 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
3361 0           $e .= $1;
3362             }
3363              
3364             # end of split
3365 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin10::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          
3366              
3367             # split scalar value
3368 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Elatin10::split' . $e . e_string($1); }
3369              
3370             # split literal space
3371 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Elatin10::split' . $e . qq {qq$1 $2}; }
3372 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; }
3373 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; }
3374 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; }
3375 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; }
3376 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; }
3377 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Elatin10::split' . $e . qq {q$1 $2}; }
3378 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; }
3379 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; }
3380 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; }
3381 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; }
3382 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; }
3383 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Elatin10::split' . $e . qq {' '}; }
3384 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Elatin10::split' . $e . qq {" "}; }
3385              
3386             # split qq//
3387             elsif (/\G \b (qq) \b /oxgc) {
3388 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3389             else {
3390 0           while (not /\G \z/oxgc) {
3391 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3392 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3393 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3394 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3395 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3396 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3397 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3398             }
3399 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3400             }
3401             }
3402              
3403             # split qr//
3404             elsif (/\G \b (qr) \b /oxgc) {
3405 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3406             else {
3407 0           while (not /\G \z/oxgc) {
3408 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3409 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3410 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3411 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3412 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3413 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3414 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3415 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3416             }
3417 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3418             }
3419             }
3420              
3421             # split q//
3422             elsif (/\G \b (q) \b /oxgc) {
3423 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3424             else {
3425 0           while (not /\G \z/oxgc) {
3426 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3427 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3428 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3429 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3430 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3431 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3432 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3433             }
3434 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3435             }
3436             }
3437              
3438             # split m//
3439             elsif (/\G \b (m) \b /oxgc) {
3440 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3441             else {
3442 0           while (not /\G \z/oxgc) {
3443 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3444 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3445 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3446 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3447 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3448 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3449 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3450 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3451             }
3452 0           die __FILE__, ": Search pattern not terminated";
3453             }
3454             }
3455              
3456             # split ''
3457             elsif (/\G (\') /oxgc) {
3458 0           my $q_string = '';
3459 0           while (not /\G \z/oxgc) {
3460 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3461 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3462 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3463 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3464             }
3465 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3466             }
3467              
3468             # split ""
3469             elsif (/\G (\") /oxgc) {
3470 0           my $qq_string = '';
3471 0           while (not /\G \z/oxgc) {
3472 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3473 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3474 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3475 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3476             }
3477 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3478             }
3479              
3480             # split //
3481             elsif (/\G (\/) /oxgc) {
3482 0           my $regexp = '';
3483 0           while (not /\G \z/oxgc) {
3484 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3485 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3486 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3487 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3488             }
3489 0           die __FILE__, ": Search pattern not terminated";
3490             }
3491             }
3492              
3493             # tr/// or y///
3494              
3495             # about [cdsrbB]* (/B modifier)
3496             #
3497             # P.559 appendix C
3498             # of ISBN 4-89052-384-7 Programming perl
3499             # (Japanese title is: Perl puroguramingu)
3500              
3501             elsif (/\G \b ( tr | y ) \b /oxgc) {
3502 0           my $ope = $1;
3503              
3504             # $1 $2 $3 $4 $5 $6
3505 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3506 0           my @tr = ($tr_variable,$2);
3507 0           return e_tr(@tr,'',$4,$6);
3508             }
3509             else {
3510 0           my $e = '';
3511 0           while (not /\G \z/oxgc) {
3512 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3513             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3514 0           my @tr = ($tr_variable,$2);
3515 0           while (not /\G \z/oxgc) {
3516 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3517 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3518 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3519 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3520 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3521 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3522             }
3523 0           die __FILE__, ": Transliteration replacement not terminated";
3524             }
3525             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3526 0           my @tr = ($tr_variable,$2);
3527 0           while (not /\G \z/oxgc) {
3528 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3529 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3530 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3531 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3532 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3533 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3534             }
3535 0           die __FILE__, ": Transliteration replacement not terminated";
3536             }
3537             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3538 0           my @tr = ($tr_variable,$2);
3539 0           while (not /\G \z/oxgc) {
3540 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3541 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3542 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3543 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3544 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3545 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3546             }
3547 0           die __FILE__, ": Transliteration replacement not terminated";
3548             }
3549             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3550 0           my @tr = ($tr_variable,$2);
3551 0           while (not /\G \z/oxgc) {
3552 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3553 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3554 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3555 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3556 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3557 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3558             }
3559 0           die __FILE__, ": Transliteration replacement not terminated";
3560             }
3561             # $1 $2 $3 $4 $5 $6
3562             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3563 0           my @tr = ($tr_variable,$2);
3564 0           return e_tr(@tr,'',$4,$6);
3565             }
3566             }
3567 0           die __FILE__, ": Transliteration pattern not terminated";
3568             }
3569             }
3570              
3571             # qq//
3572             elsif (/\G \b (qq) \b /oxgc) {
3573 0           my $ope = $1;
3574              
3575             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3576 0 0         if (/\G (\#) /oxgc) { # qq# #
3577 0           my $qq_string = '';
3578 0           while (not /\G \z/oxgc) {
3579 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3580 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3581 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3582 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3583             }
3584 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3585             }
3586              
3587             else {
3588 0           my $e = '';
3589 0           while (not /\G \z/oxgc) {
3590 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3591              
3592             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3593             elsif (/\G (\() /oxgc) { # qq ( )
3594 0           my $qq_string = '';
3595 0           local $nest = 1;
3596 0           while (not /\G \z/oxgc) {
3597 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3598 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3599 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3600             elsif (/\G (\)) /oxgc) {
3601 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3602 0           else { $qq_string .= $1; }
3603             }
3604 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3605             }
3606 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3607             }
3608              
3609             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3610             elsif (/\G (\{) /oxgc) { # qq { }
3611 0           my $qq_string = '';
3612 0           local $nest = 1;
3613 0           while (not /\G \z/oxgc) {
3614 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3615 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3616 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3617             elsif (/\G (\}) /oxgc) {
3618 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3619 0           else { $qq_string .= $1; }
3620             }
3621 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3622             }
3623 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3624             }
3625              
3626             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3627             elsif (/\G (\[) /oxgc) { # qq [ ]
3628 0           my $qq_string = '';
3629 0           local $nest = 1;
3630 0           while (not /\G \z/oxgc) {
3631 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3632 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3633 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3634             elsif (/\G (\]) /oxgc) {
3635 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3636 0           else { $qq_string .= $1; }
3637             }
3638 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3639             }
3640 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3641             }
3642              
3643             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3644             elsif (/\G (\<) /oxgc) { # qq < >
3645 0           my $qq_string = '';
3646 0           local $nest = 1;
3647 0           while (not /\G \z/oxgc) {
3648 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3649 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3650 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3651             elsif (/\G (\>) /oxgc) {
3652 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3653 0           else { $qq_string .= $1; }
3654             }
3655 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3656             }
3657 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3658             }
3659              
3660             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3661             elsif (/\G (\S) /oxgc) { # qq * *
3662 0           my $delimiter = $1;
3663 0           my $qq_string = '';
3664 0           while (not /\G \z/oxgc) {
3665 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3666 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3667 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3668 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3669             }
3670 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3671             }
3672             }
3673 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3674             }
3675             }
3676              
3677             # qr//
3678             elsif (/\G \b (qr) \b /oxgc) {
3679 0           my $ope = $1;
3680 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
3681 0           return e_qr($ope,$1,$3,$2,$4);
3682             }
3683             else {
3684 0           my $e = '';
3685 0           while (not /\G \z/oxgc) {
3686 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3687 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3688 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3689 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3690 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3691 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3692 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3693 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3694             }
3695 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3696             }
3697             }
3698              
3699             # qw//
3700             elsif (/\G \b (qw) \b /oxgc) {
3701 0           my $ope = $1;
3702 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3703 0           return e_qw($ope,$1,$3,$2);
3704             }
3705             else {
3706 0           my $e = '';
3707 0           while (not /\G \z/oxgc) {
3708 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3709              
3710 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3711 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3712              
3713 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3714 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3715              
3716 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3717 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3718              
3719 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3720 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3721              
3722 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3723 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3724             }
3725 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3726             }
3727             }
3728              
3729             # qx//
3730             elsif (/\G \b (qx) \b /oxgc) {
3731 0           my $ope = $1;
3732 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3733 0           return e_qq($ope,$1,$3,$2);
3734             }
3735             else {
3736 0           my $e = '';
3737 0           while (not /\G \z/oxgc) {
3738 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3739 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3740 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3741 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3742 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3743 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3744 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3745             }
3746 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3747             }
3748             }
3749              
3750             # q//
3751             elsif (/\G \b (q) \b /oxgc) {
3752 0           my $ope = $1;
3753              
3754             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3755              
3756             # avoid "Error: Runtime exception" of perl version 5.005_03
3757             # (and so on)
3758              
3759 0 0         if (/\G (\#) /oxgc) { # q# #
3760 0           my $q_string = '';
3761 0           while (not /\G \z/oxgc) {
3762 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3763 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3764 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3765 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3766             }
3767 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3768             }
3769              
3770             else {
3771 0           my $e = '';
3772 0           while (not /\G \z/oxgc) {
3773 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3774              
3775             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3776             elsif (/\G (\() /oxgc) { # q ( )
3777 0           my $q_string = '';
3778 0           local $nest = 1;
3779 0           while (not /\G \z/oxgc) {
3780 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3781 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3782 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3783 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3784             elsif (/\G (\)) /oxgc) {
3785 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3786 0           else { $q_string .= $1; }
3787             }
3788 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3789             }
3790 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3791             }
3792              
3793             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3794             elsif (/\G (\{) /oxgc) { # q { }
3795 0           my $q_string = '';
3796 0           local $nest = 1;
3797 0           while (not /\G \z/oxgc) {
3798 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3799 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3800 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3801 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3802             elsif (/\G (\}) /oxgc) {
3803 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3804 0           else { $q_string .= $1; }
3805             }
3806 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3807             }
3808 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3809             }
3810              
3811             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3812             elsif (/\G (\[) /oxgc) { # q [ ]
3813 0           my $q_string = '';
3814 0           local $nest = 1;
3815 0           while (not /\G \z/oxgc) {
3816 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3817 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3818 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3819 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3820             elsif (/\G (\]) /oxgc) {
3821 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3822 0           else { $q_string .= $1; }
3823             }
3824 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3825             }
3826 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3827             }
3828              
3829             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3830             elsif (/\G (\<) /oxgc) { # q < >
3831 0           my $q_string = '';
3832 0           local $nest = 1;
3833 0           while (not /\G \z/oxgc) {
3834 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3835 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3836 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3837 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3838             elsif (/\G (\>) /oxgc) {
3839 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3840 0           else { $q_string .= $1; }
3841             }
3842 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3843             }
3844 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3845             }
3846              
3847             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3848             elsif (/\G (\S) /oxgc) { # q * *
3849 0           my $delimiter = $1;
3850 0           my $q_string = '';
3851 0           while (not /\G \z/oxgc) {
3852 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3853 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3854 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3855 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3856             }
3857 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3858             }
3859             }
3860 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3861             }
3862             }
3863              
3864             # m//
3865             elsif (/\G \b (m) \b /oxgc) {
3866 0           my $ope = $1;
3867 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
3868 0           return e_qr($ope,$1,$3,$2,$4);
3869             }
3870             else {
3871 0           my $e = '';
3872 0           while (not /\G \z/oxgc) {
3873 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3874 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3875 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3876 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3877 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3878 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3879 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3880 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3881 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3882             }
3883 0           die __FILE__, ": Search pattern not terminated";
3884             }
3885             }
3886              
3887             # s///
3888              
3889             # about [cegimosxpradlubB]* (/cg modifier)
3890             #
3891             # P.67 Pattern-Matching Operators
3892             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3893              
3894             elsif (/\G \b (s) \b /oxgc) {
3895 0           my $ope = $1;
3896              
3897             # $1 $2 $3 $4 $5 $6
3898 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
3899 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3900             }
3901             else {
3902 0           my $e = '';
3903 0           while (not /\G \z/oxgc) {
3904 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3905             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3906 0           my @s = ($1,$2,$3);
3907 0           while (not /\G \z/oxgc) {
3908 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3909             # $1 $2 $3 $4
3910 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3911 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3916 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3917 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3918 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3919             }
3920 0           die __FILE__, ": Substitution replacement not terminated";
3921             }
3922             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3923 0           my @s = ($1,$2,$3);
3924 0           while (not /\G \z/oxgc) {
3925 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3926             # $1 $2 $3 $4
3927 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936             }
3937 0           die __FILE__, ": Substitution replacement not terminated";
3938             }
3939             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3940 0           my @s = ($1,$2,$3);
3941 0           while (not /\G \z/oxgc) {
3942 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3943             # $1 $2 $3 $4
3944 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951             }
3952 0           die __FILE__, ": Substitution replacement not terminated";
3953             }
3954             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3955 0           my @s = ($1,$2,$3);
3956 0           while (not /\G \z/oxgc) {
3957 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3958             # $1 $2 $3 $4
3959 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968             }
3969 0           die __FILE__, ": Substitution replacement not terminated";
3970             }
3971             # $1 $2 $3 $4 $5 $6
3972             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
3973 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3974             }
3975             # $1 $2 $3 $4 $5 $6
3976             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3977 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3978             }
3979             # $1 $2 $3 $4 $5 $6
3980             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3981 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3982             }
3983             # $1 $2 $3 $4 $5 $6
3984             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3985 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3986             }
3987             }
3988 0           die __FILE__, ": Substitution pattern not terminated";
3989             }
3990             }
3991              
3992             # require ignore module
3993 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3994 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3995 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3996              
3997             # use strict; --> use strict; no strict qw(refs);
3998 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3999 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4000 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4001              
4002             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4003             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
4004 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
4005 0           return "use $1; no strict qw(refs);";
4006             }
4007             else {
4008 0           return "use $1;";
4009             }
4010             }
4011             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
4012 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4013 0           return "use $1; no strict qw(refs);";
4014             }
4015             else {
4016 0           return "use $1;";
4017             }
4018             }
4019              
4020             # ignore use module
4021 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4022 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4023 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4024              
4025             # ignore no module
4026 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4027 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4028 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4029              
4030             # use else
4031 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4032              
4033             # use else
4034 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4035              
4036             # ''
4037             elsif (/\G (?
4038 0           my $q_string = '';
4039 0           while (not /\G \z/oxgc) {
4040 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4041 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4042 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4043 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4044             }
4045 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4046             }
4047              
4048             # ""
4049             elsif (/\G (\") /oxgc) {
4050 0           my $qq_string = '';
4051 0           while (not /\G \z/oxgc) {
4052 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4053 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4054 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4055 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4056             }
4057 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4058             }
4059              
4060             # ``
4061             elsif (/\G (\`) /oxgc) {
4062 0           my $qx_string = '';
4063 0           while (not /\G \z/oxgc) {
4064 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4065 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4066 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4067 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4068             }
4069 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4070             }
4071              
4072             # // --- not divide operator (num / num), not defined-or
4073             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4074 0           my $regexp = '';
4075 0           while (not /\G \z/oxgc) {
4076 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4077 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4078 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4079 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4080             }
4081 0           die __FILE__, ": Search pattern not terminated";
4082             }
4083              
4084             # ?? --- not conditional operator (condition ? then : else)
4085             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4086 0           my $regexp = '';
4087 0           while (not /\G \z/oxgc) {
4088 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4089 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4090 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4091 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4092             }
4093 0           die __FILE__, ": Search pattern not terminated";
4094             }
4095              
4096             # << (bit shift) --- not here document
4097 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4098              
4099             # <<'HEREDOC'
4100             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4101 0           $slash = 'm//';
4102 0           my $here_quote = $1;
4103 0           my $delimiter = $2;
4104              
4105             # get here document
4106 0 0         if ($here_script eq '') {
4107 0           $here_script = CORE::substr $_, pos $_;
4108 0           $here_script =~ s/.*?\n//oxm;
4109             }
4110 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4111 0           push @heredoc, $1 . qq{\n$delimiter\n};
4112 0           push @heredoc_delimiter, $delimiter;
4113             }
4114             else {
4115 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4116             }
4117 0           return $here_quote;
4118             }
4119              
4120             # <<\HEREDOC
4121              
4122             # P.66 2.6.6. "Here" Documents
4123             # in Chapter 2: Bits and Pieces
4124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4125              
4126             # P.73 "Here" Documents
4127             # in Chapter 2: Bits and Pieces
4128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4129              
4130             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4131 0           $slash = 'm//';
4132 0           my $here_quote = $1;
4133 0           my $delimiter = $2;
4134              
4135             # get here document
4136 0 0         if ($here_script eq '') {
4137 0           $here_script = CORE::substr $_, pos $_;
4138 0           $here_script =~ s/.*?\n//oxm;
4139             }
4140 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4141 0           push @heredoc, $1 . qq{\n$delimiter\n};
4142 0           push @heredoc_delimiter, $delimiter;
4143             }
4144             else {
4145 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4146             }
4147 0           return $here_quote;
4148             }
4149              
4150             # <<"HEREDOC"
4151             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4152 0           $slash = 'm//';
4153 0           my $here_quote = $1;
4154 0           my $delimiter = $2;
4155              
4156             # get here document
4157 0 0         if ($here_script eq '') {
4158 0           $here_script = CORE::substr $_, pos $_;
4159 0           $here_script =~ s/.*?\n//oxm;
4160             }
4161 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4162 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4163 0           push @heredoc_delimiter, $delimiter;
4164             }
4165             else {
4166 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4167             }
4168 0           return $here_quote;
4169             }
4170              
4171             # <
4172             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4173 0           $slash = 'm//';
4174 0           my $here_quote = $1;
4175 0           my $delimiter = $2;
4176              
4177             # get here document
4178 0 0         if ($here_script eq '') {
4179 0           $here_script = CORE::substr $_, pos $_;
4180 0           $here_script =~ s/.*?\n//oxm;
4181             }
4182 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4183 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4184 0           push @heredoc_delimiter, $delimiter;
4185             }
4186             else {
4187 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4188             }
4189 0           return $here_quote;
4190             }
4191              
4192             # <<`HEREDOC`
4193             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4194 0           $slash = 'm//';
4195 0           my $here_quote = $1;
4196 0           my $delimiter = $2;
4197              
4198             # get here document
4199 0 0         if ($here_script eq '') {
4200 0           $here_script = CORE::substr $_, pos $_;
4201 0           $here_script =~ s/.*?\n//oxm;
4202             }
4203 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4204 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4205 0           push @heredoc_delimiter, $delimiter;
4206             }
4207             else {
4208 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4209             }
4210 0           return $here_quote;
4211             }
4212              
4213             # <<= <=> <= < operator
4214             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4215 0           return $1;
4216             }
4217              
4218             #
4219             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4220 0           return $1;
4221             }
4222              
4223             # --- glob
4224              
4225             # avoid "Error: Runtime exception" of perl version 5.005_03
4226              
4227             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4228 0           return 'Char::Elatin10::glob("' . $1 . '")';
4229             }
4230              
4231             # __DATA__
4232 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4233              
4234             # __END__
4235 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4236              
4237             # \cD Control-D
4238              
4239             # P.68 2.6.8. Other Literal Tokens
4240             # in Chapter 2: Bits and Pieces
4241             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4242              
4243             # P.76 Other Literal Tokens
4244             # in Chapter 2: Bits and Pieces
4245             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4246              
4247 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4248              
4249             # \cZ Control-Z
4250 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4251              
4252             # any operator before div
4253             elsif (/\G (
4254             -- | \+\+ |
4255             [\)\}\]]
4256              
4257 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4258              
4259             # yada-yada or triple-dot operator
4260             elsif (/\G (
4261             \.\.\.
4262              
4263 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4264              
4265             # any operator before m//
4266              
4267             # //, //= (defined-or)
4268              
4269             # P.164 Logical Operators
4270             # in Chapter 10: More Control Structures
4271             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4272              
4273             # P.119 C-Style Logical (Short-Circuit) Operators
4274             # in Chapter 3: Unary and Binary Operators
4275             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4276              
4277             # (and so on)
4278              
4279             # ~~
4280              
4281             # P.221 The Smart Match Operator
4282             # in Chapter 15: Smart Matching and given-when
4283             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4284              
4285             # P.112 Smartmatch Operator
4286             # in Chapter 3: Unary and Binary Operators
4287             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4288              
4289             # (and so on)
4290              
4291             elsif (/\G (
4292              
4293             !~~ | !~ | != | ! |
4294             %= | % |
4295             &&= | && | &= | & |
4296             -= | -> | - |
4297             :\s*= |
4298             : |
4299             <<= | <=> | <= | < |
4300             == | => | =~ | = |
4301             >>= | >> | >= | > |
4302             \*\*= | \*\* | \*= | \* |
4303             \+= | \+ |
4304             \.\. | \.= | \. |
4305             \/\/= | \/\/ |
4306             \/= | \/ |
4307             \? |
4308             \\ |
4309             \^= | \^ |
4310             \b x= |
4311             \|\|= | \|\| | \|= | \| |
4312             ~~ | ~ |
4313             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4314             \b(?: print )\b |
4315              
4316             [,;\(\{\[]
4317              
4318 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4319              
4320             # other any character
4321 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4322              
4323             # system error
4324             else {
4325 0           die __FILE__, ": Oops, this shouldn't happen!";
4326             }
4327             }
4328              
4329             # escape Latin-10 string
4330             sub e_string {
4331 0     0 0   my($string) = @_;
4332 0           my $e_string = '';
4333              
4334 0           local $slash = 'm//';
4335              
4336             # P.1024 Appendix W.10 Multibyte Processing
4337             # of ISBN 1-56592-224-7 CJKV Information Processing
4338             # (and so on)
4339              
4340 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
4341              
4342             # without { ... }
4343 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4344 0 0         if ($string !~ /<
4345 0           return $string;
4346             }
4347             }
4348              
4349             E_STRING_LOOP:
4350 0           while ($string !~ /\G \z/oxgc) {
4351 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          
4352             }
4353              
4354             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Elatin10::PREMATCH()]}
4355 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
4356 0           $e_string .= q{Char::Elatin10::PREMATCH()};
4357 0           $slash = 'div';
4358             }
4359              
4360             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Elatin10::MATCH()]}
4361             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
4362 0           $e_string .= q{Char::Elatin10::MATCH()};
4363 0           $slash = 'div';
4364             }
4365              
4366             # $', ${'} --> $', ${'}
4367             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4368 0           $e_string .= $1;
4369 0           $slash = 'div';
4370             }
4371              
4372             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Elatin10::POSTMATCH()]}
4373             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
4374 0           $e_string .= q{Char::Elatin10::POSTMATCH()};
4375 0           $slash = 'div';
4376             }
4377              
4378             # bareword
4379             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
4380 0           $e_string .= $1;
4381 0           $slash = 'div';
4382             }
4383              
4384             # $0 --> $0
4385             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4386 0           $e_string .= $1;
4387 0           $slash = 'div';
4388             }
4389             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
4390 0           $e_string .= $1;
4391 0           $slash = 'div';
4392             }
4393              
4394             # $$ --> $$
4395             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4396 0           $e_string .= $1;
4397 0           $slash = 'div';
4398             }
4399              
4400             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4401             # $1, $2, $3 --> $1, $2, $3 otherwise
4402             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
4403 0           $e_string .= e_capture($1);
4404 0           $slash = 'div';
4405             }
4406             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
4407 0           $e_string .= e_capture($1);
4408 0           $slash = 'div';
4409             }
4410              
4411             # $$foo[ ... ] --> $ $foo->[ ... ]
4412             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
4413 0           $e_string .= e_capture($1.'->'.$2);
4414 0           $slash = 'div';
4415             }
4416              
4417             # $$foo{ ... } --> $ $foo->{ ... }
4418             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
4419 0           $e_string .= e_capture($1.'->'.$2);
4420 0           $slash = 'div';
4421             }
4422              
4423             # $$foo
4424             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
4425 0           $e_string .= e_capture($1);
4426 0           $slash = 'div';
4427             }
4428              
4429             # ${ foo }
4430             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
4431 0           $e_string .= '${' . $1 . '}';
4432 0           $slash = 'div';
4433             }
4434              
4435             # ${ ... }
4436             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
4437 0           $e_string .= e_capture($1);
4438 0           $slash = 'div';
4439             }
4440              
4441             # variable or function
4442             # $ @ % & * $ #
4443             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) {
4444 0           $e_string .= $1;
4445 0           $slash = 'div';
4446             }
4447             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4448             # $ @ # \ ' " / ? ( ) [ ] < >
4449             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4450 0           $e_string .= $1;
4451 0           $slash = 'div';
4452             }
4453              
4454             # subroutines of package Char::Elatin10
4455 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4456 0           elsif ($string =~ /\G \b Char::Latin10::eval (?= \s* \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4457 0           elsif ($string =~ /\G \b Char::Latin10::eval \b /oxgc) { $e_string .= 'eval Char::Latin10::escape'; $slash = 'm//'; }
  0            
4458 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4459 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Elatin10::chop'; $slash = 'm//'; }
  0            
4460 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4461 0           elsif ($string =~ /\G \b Char::Latin10::index \b /oxgc) { $e_string .= 'Char::Latin10::index'; $slash = 'm//'; }
  0            
4462 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Elatin10::index'; $slash = 'm//'; }
  0            
4463 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4464 0           elsif ($string =~ /\G \b Char::Latin10::rindex \b /oxgc) { $e_string .= 'Char::Latin10::rindex'; $slash = 'm//'; }
  0            
4465 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Elatin10::rindex'; $slash = 'm//'; }
  0            
4466 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin10::lc'; $slash = 'm//'; }
  0            
4467 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin10::lcfirst'; $slash = 'm//'; }
  0            
4468 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin10::uc'; $slash = 'm//'; }
  0            
4469 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin10::ucfirst'; $slash = 'm//'; }
  0            
4470 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin10::fc'; $slash = 'm//'; }
  0            
4471              
4472             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4473 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4474 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4475 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4476 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4477 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4478 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4479 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            
4480              
4481 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4482 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4483 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4484 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4485 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4486 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4487 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            
4488              
4489             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
4490 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4491 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4492 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4493 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4494              
4495 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4496 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4497 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin10::chr'; $slash = 'm//'; }
  0            
4498 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4499 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4500 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin10::glob'; $slash = 'm//'; }
  0            
4501 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Elatin10::lc_'; $slash = 'm//'; }
  0            
4502 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Elatin10::lcfirst_'; $slash = 'm//'; }
  0            
4503 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Elatin10::uc_'; $slash = 'm//'; }
  0            
4504 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Elatin10::ucfirst_'; $slash = 'm//'; }
  0            
4505 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Elatin10::fc_'; $slash = 'm//'; }
  0            
4506 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4507              
4508 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4509 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4510 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Elatin10::chr_'; $slash = 'm//'; }
  0            
4511 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4512 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4513 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Elatin10::glob_'; $slash = 'm//'; }
  0            
4514 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4515 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4516             # split
4517             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
4518 0           $slash = 'm//';
4519              
4520 0           my $e = '';
4521 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
4522 0           $e .= $1;
4523             }
4524              
4525             # end of split
4526 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin10::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          
4527              
4528             # split scalar value
4529 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4530              
4531             # split literal space
4532 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4533 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4534 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4535 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4536 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4537 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4538 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4539 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4540 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4541 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4542 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4543 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4544 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4545 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Elatin10::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4546              
4547             # split qq//
4548             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4549 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            
4550             else {
4551 0           while ($string !~ /\G \z/oxgc) {
4552 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4553 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4554 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4555 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4556 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4557 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4558 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            
4559             }
4560 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4561             }
4562             }
4563              
4564             # split qr//
4565             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4566 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            
4567             else {
4568 0           while ($string !~ /\G \z/oxgc) {
4569 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4570 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4571 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4572 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4573 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4574 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            
4575 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4576 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            
4577             }
4578 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4579             }
4580             }
4581              
4582             # split q//
4583             elsif ($string =~ /\G \b (q) \b /oxgc) {
4584 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            
4585             else {
4586 0           while ($string !~ /\G \z/oxgc) {
4587 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4588 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4589 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4590 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4591 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4592 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4593 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            
4594             }
4595 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4596             }
4597             }
4598              
4599             # split m//
4600             elsif ($string =~ /\G \b (m) \b /oxgc) {
4601 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            
4602             else {
4603 0           while ($string !~ /\G \z/oxgc) {
4604 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4605 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            
4606 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            
4607 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            
4608 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            
4609 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            
4610 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4611 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            
4612             }
4613 0           die __FILE__, ": Search pattern not terminated";
4614             }
4615             }
4616              
4617             # split ''
4618             elsif ($string =~ /\G (\') /oxgc) {
4619 0           my $q_string = '';
4620 0           while ($string !~ /\G \z/oxgc) {
4621 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4622 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4623 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4624 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4625             }
4626 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4627             }
4628              
4629             # split ""
4630             elsif ($string =~ /\G (\") /oxgc) {
4631 0           my $qq_string = '';
4632 0           while ($string !~ /\G \z/oxgc) {
4633 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4634 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4635 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4636 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4637             }
4638 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4639             }
4640              
4641             # split //
4642             elsif ($string =~ /\G (\/) /oxgc) {
4643 0           my $regexp = '';
4644 0           while ($string !~ /\G \z/oxgc) {
4645 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4646 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4647 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4648 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4649             }
4650 0           die __FILE__, ": Search pattern not terminated";
4651             }
4652             }
4653              
4654             # qq//
4655             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4656 0           my $ope = $1;
4657 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4658 0           $e_string .= e_qq($ope,$1,$3,$2);
4659             }
4660             else {
4661 0           my $e = '';
4662 0           while ($string !~ /\G \z/oxgc) {
4663 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4664 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4665 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4666 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4667 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4668 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4669             }
4670 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4671             }
4672             }
4673              
4674             # qx//
4675             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4676 0           my $ope = $1;
4677 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4678 0           $e_string .= e_qq($ope,$1,$3,$2);
4679             }
4680             else {
4681 0           my $e = '';
4682 0           while ($string !~ /\G \z/oxgc) {
4683 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4684 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4685 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4686 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4687 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4688 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4689 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4690             }
4691 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4692             }
4693             }
4694              
4695             # q//
4696             elsif ($string =~ /\G \b (q) \b /oxgc) {
4697 0           my $ope = $1;
4698 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4699 0           $e_string .= e_q($ope,$1,$3,$2);
4700             }
4701             else {
4702 0           my $e = '';
4703 0           while ($string !~ /\G \z/oxgc) {
4704 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4705 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4706 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4707 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4708 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4709 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            
4710             }
4711 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4712             }
4713             }
4714              
4715             # ''
4716 0           elsif ($string =~ /\G (?
4717              
4718             # ""
4719 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4720              
4721             # ``
4722 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4723              
4724             # <<= <=> <= < operator
4725             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
4726 0           { $e_string .= $1; }
4727              
4728             #
4729 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4730              
4731             # --- glob
4732             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4733 0           $e_string .= 'Char::Elatin10::glob("' . $1 . '")';
4734             }
4735              
4736             # << (bit shift) --- not here document
4737 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4738              
4739             # <<'HEREDOC'
4740             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4741 0           $slash = 'm//';
4742 0           my $here_quote = $1;
4743 0           my $delimiter = $2;
4744              
4745             # get here document
4746 0 0         if ($here_script eq '') {
4747 0           $here_script = CORE::substr $_, pos $_;
4748 0           $here_script =~ s/.*?\n//oxm;
4749             }
4750 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4751 0           push @heredoc, $1 . qq{\n$delimiter\n};
4752 0           push @heredoc_delimiter, $delimiter;
4753             }
4754             else {
4755 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4756             }
4757 0           $e_string .= $here_quote;
4758             }
4759              
4760             # <<\HEREDOC
4761             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4762 0           $slash = 'm//';
4763 0           my $here_quote = $1;
4764 0           my $delimiter = $2;
4765              
4766             # get here document
4767 0 0         if ($here_script eq '') {
4768 0           $here_script = CORE::substr $_, pos $_;
4769 0           $here_script =~ s/.*?\n//oxm;
4770             }
4771 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4772 0           push @heredoc, $1 . qq{\n$delimiter\n};
4773 0           push @heredoc_delimiter, $delimiter;
4774             }
4775             else {
4776 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4777             }
4778 0           $e_string .= $here_quote;
4779             }
4780              
4781             # <<"HEREDOC"
4782             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4783 0           $slash = 'm//';
4784 0           my $here_quote = $1;
4785 0           my $delimiter = $2;
4786              
4787             # get here document
4788 0 0         if ($here_script eq '') {
4789 0           $here_script = CORE::substr $_, pos $_;
4790 0           $here_script =~ s/.*?\n//oxm;
4791             }
4792 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4793 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4794 0           push @heredoc_delimiter, $delimiter;
4795             }
4796             else {
4797 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4798             }
4799 0           $e_string .= $here_quote;
4800             }
4801              
4802             # <
4803             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4804 0           $slash = 'm//';
4805 0           my $here_quote = $1;
4806 0           my $delimiter = $2;
4807              
4808             # get here document
4809 0 0         if ($here_script eq '') {
4810 0           $here_script = CORE::substr $_, pos $_;
4811 0           $here_script =~ s/.*?\n//oxm;
4812             }
4813 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4814 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4815 0           push @heredoc_delimiter, $delimiter;
4816             }
4817             else {
4818 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4819             }
4820 0           $e_string .= $here_quote;
4821             }
4822              
4823             # <<`HEREDOC`
4824             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4825 0           $slash = 'm//';
4826 0           my $here_quote = $1;
4827 0           my $delimiter = $2;
4828              
4829             # get here document
4830 0 0         if ($here_script eq '') {
4831 0           $here_script = CORE::substr $_, pos $_;
4832 0           $here_script =~ s/.*?\n//oxm;
4833             }
4834 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4835 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4836 0           push @heredoc_delimiter, $delimiter;
4837             }
4838             else {
4839 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4840             }
4841 0           $e_string .= $here_quote;
4842             }
4843              
4844             # any operator before div
4845             elsif ($string =~ /\G (
4846             -- | \+\+ |
4847             [\)\}\]]
4848              
4849 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4850              
4851             # yada-yada or triple-dot operator
4852             elsif ($string =~ /\G (
4853             \.\.\.
4854              
4855 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4856              
4857             # any operator before m//
4858             elsif ($string =~ /\G (
4859              
4860             !~~ | !~ | != | ! |
4861             %= | % |
4862             &&= | && | &= | & |
4863             -= | -> | - |
4864             :\s*= |
4865             : |
4866             <<= | <=> | <= | < |
4867             == | => | =~ | = |
4868             >>= | >> | >= | > |
4869             \*\*= | \*\* | \*= | \* |
4870             \+= | \+ |
4871             \.\. | \.= | \. |
4872             \/\/= | \/\/ |
4873             \/= | \/ |
4874             \? |
4875             \\ |
4876             \^= | \^ |
4877             \b x= |
4878             \|\|= | \|\| | \|= | \| |
4879             ~~ | ~ |
4880             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4881             \b(?: print )\b |
4882              
4883             [,;\(\{\[]
4884              
4885 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4886              
4887             # other any character
4888 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4889              
4890             # system error
4891             else {
4892 0           die __FILE__, ": Oops, this shouldn't happen!";
4893             }
4894             }
4895              
4896 0           return $e_string;
4897             }
4898              
4899             #
4900             # character class
4901             #
4902             sub character_class {
4903 0     0 0   my($char,$modifier) = @_;
4904              
4905 0 0         if ($char eq '.') {
4906 0 0         if ($modifier =~ /s/) {
4907 0           return '${Char::Elatin10::dot_s}';
4908             }
4909             else {
4910 0           return '${Char::Elatin10::dot}';
4911             }
4912             }
4913             else {
4914 0           return Char::Elatin10::classic_character_class($char);
4915             }
4916             }
4917              
4918             #
4919             # escape capture ($1, $2, $3, ...)
4920             #
4921             sub e_capture {
4922              
4923 0     0 0   return join '', '${', $_[0], '}';
4924             }
4925              
4926             #
4927             # escape transliteration (tr/// or y///)
4928             #
4929             sub e_tr {
4930 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4931 0           my $e_tr = '';
4932 0   0       $modifier ||= '';
4933              
4934 0           $slash = 'div';
4935              
4936             # quote character class 1
4937 0           $charclass = q_tr($charclass);
4938              
4939             # quote character class 2
4940 0           $charclass2 = q_tr($charclass2);
4941              
4942             # /b /B modifier
4943 0 0         if ($modifier =~ tr/bB//d) {
4944 0 0         if ($variable eq '') {
4945 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4946             }
4947             else {
4948 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4949             }
4950             }
4951             else {
4952 0 0         if ($variable eq '') {
4953 0           $e_tr = qq{Char::Elatin10::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4954             }
4955             else {
4956 0           $e_tr = qq{Char::Elatin10::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4957             }
4958             }
4959              
4960             # clear tr/// variable
4961 0           $tr_variable = '';
4962 0           $bind_operator = '';
4963              
4964 0           return $e_tr;
4965             }
4966              
4967             #
4968             # quote for escape transliteration (tr/// or y///)
4969             #
4970             sub q_tr {
4971 0     0 0   my($charclass) = @_;
4972              
4973             # quote character class
4974 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4975 0           return e_q('', "'", "'", $charclass); # --> q' '
4976             }
4977             elsif ($charclass !~ /\//oxms) {
4978 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4979             }
4980             elsif ($charclass !~ /\#/oxms) {
4981 0           return e_q('q', '#', '#', $charclass); # --> q# #
4982             }
4983             elsif ($charclass !~ /[\<\>]/oxms) {
4984 0           return e_q('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             else {
4993 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4994 0 0         if ($charclass !~ /\Q$char\E/xms) {
4995 0           return e_q('q', $char, $char, $charclass);
4996             }
4997             }
4998             }
4999              
5000 0           return e_q('q', '{', '}', $charclass);
5001             }
5002              
5003             #
5004             # escape q string (q//, '')
5005             #
5006             sub e_q {
5007 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5008              
5009 0           $slash = 'div';
5010              
5011 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5012             }
5013              
5014             #
5015             # escape qq string (qq//, "", qx//, ``)
5016             #
5017             sub e_qq {
5018 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5019              
5020 0           $slash = 'div';
5021              
5022 0           my $left_e = 0;
5023 0           my $right_e = 0;
5024 0           my @char = $string =~ /\G(
5025             \\o\{ [0-7]+ \} |
5026             \\x\{ [0-9A-Fa-f]+ \} |
5027             \\N\{ [^0-9\}][^\}]* \} |
5028             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5029             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5030             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5031             \$ \s* \d+ |
5032             \$ \s* \{ \s* \d+ \s* \} |
5033             \$ \$ (?![\w\{]) |
5034             \$ \s* \$ \s* $qq_variable |
5035             \\?(?:$q_char)
5036             )/oxmsg;
5037              
5038 0           for (my $i=0; $i <= $#char; $i++) {
5039              
5040             # "\L\u" --> "\u\L"
5041 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5042 0           @char[$i,$i+1] = @char[$i+1,$i];
5043             }
5044              
5045             # "\U\l" --> "\l\U"
5046             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5047 0           @char[$i,$i+1] = @char[$i+1,$i];
5048             }
5049              
5050             # octal escape sequence
5051             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5052 0           $char[$i] = Char::Elatin10::octchr($1);
5053             }
5054              
5055             # hexadecimal escape sequence
5056             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5057 0           $char[$i] = Char::Elatin10::hexchr($1);
5058             }
5059              
5060             # \N{CHARNAME} --> N{CHARNAME}
5061             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5062 0           $char[$i] = $1;
5063             }
5064              
5065 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          
5066             }
5067              
5068             # \F
5069             #
5070             # P.69 Table 2-6. Translation escapes
5071             # in Chapter 2: Bits and Pieces
5072             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5073             # (and so on)
5074              
5075             # \u \l \U \L \F \Q \E
5076 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5077 0 0         if ($right_e < $left_e) {
5078 0           $char[$i] = '\\' . $char[$i];
5079             }
5080             }
5081             elsif ($char[$i] eq '\u') {
5082              
5083             # "STRING @{[ LIST EXPR ]} MORE STRING"
5084              
5085             # P.257 Other Tricks You Can Do with Hard References
5086             # in Chapter 8: References
5087             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5088              
5089             # P.353 Other Tricks You Can Do with Hard References
5090             # in Chapter 8: References
5091             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5092              
5093             # (and so on)
5094              
5095 0           $char[$i] = '@{[Char::Elatin10::ucfirst qq<';
5096 0           $left_e++;
5097             }
5098             elsif ($char[$i] eq '\l') {
5099 0           $char[$i] = '@{[Char::Elatin10::lcfirst qq<';
5100 0           $left_e++;
5101             }
5102             elsif ($char[$i] eq '\U') {
5103 0           $char[$i] = '@{[Char::Elatin10::uc qq<';
5104 0           $left_e++;
5105             }
5106             elsif ($char[$i] eq '\L') {
5107 0           $char[$i] = '@{[Char::Elatin10::lc qq<';
5108 0           $left_e++;
5109             }
5110             elsif ($char[$i] eq '\F') {
5111 0           $char[$i] = '@{[Char::Elatin10::fc qq<';
5112 0           $left_e++;
5113             }
5114             elsif ($char[$i] eq '\Q') {
5115 0           $char[$i] = '@{[CORE::quotemeta qq<';
5116 0           $left_e++;
5117             }
5118             elsif ($char[$i] eq '\E') {
5119 0 0         if ($right_e < $left_e) {
5120 0           $char[$i] = '>]}';
5121 0           $right_e++;
5122             }
5123             else {
5124 0           $char[$i] = '';
5125             }
5126             }
5127             elsif ($char[$i] eq '\Q') {
5128 0           while (1) {
5129 0 0         if (++$i > $#char) {
5130 0           last;
5131             }
5132 0 0         if ($char[$i] eq '\E') {
5133 0           last;
5134             }
5135             }
5136             }
5137             elsif ($char[$i] eq '\E') {
5138             }
5139              
5140             # $0 --> $0
5141             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5142             }
5143             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5144             }
5145              
5146             # $$ --> $$
5147             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5148             }
5149              
5150             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5151             # $1, $2, $3 --> $1, $2, $3 otherwise
5152             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5153 0           $char[$i] = e_capture($1);
5154             }
5155             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5156 0           $char[$i] = e_capture($1);
5157             }
5158              
5159             # $$foo[ ... ] --> $ $foo->[ ... ]
5160             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5161 0           $char[$i] = e_capture($1.'->'.$2);
5162             }
5163              
5164             # $$foo{ ... } --> $ $foo->{ ... }
5165             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5166 0           $char[$i] = e_capture($1.'->'.$2);
5167             }
5168              
5169             # $$foo
5170             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5171 0           $char[$i] = e_capture($1);
5172             }
5173              
5174             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin10::PREMATCH()
5175             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5176 0           $char[$i] = '@{[Char::Elatin10::PREMATCH()]}';
5177             }
5178              
5179             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin10::MATCH()
5180             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5181 0           $char[$i] = '@{[Char::Elatin10::MATCH()]}';
5182             }
5183              
5184             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin10::POSTMATCH()
5185             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5186 0           $char[$i] = '@{[Char::Elatin10::POSTMATCH()]}';
5187             }
5188              
5189             # ${ foo } --> ${ foo }
5190             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5191             }
5192              
5193             # ${ ... }
5194             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5195 0           $char[$i] = e_capture($1);
5196             }
5197             }
5198              
5199             # return string
5200 0 0         if ($left_e > $right_e) {
5201 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5202             }
5203 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5204             }
5205              
5206             #
5207             # escape qw string (qw//)
5208             #
5209             sub e_qw {
5210 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5211              
5212 0           $slash = 'div';
5213              
5214             # choice again delimiter
5215 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5216 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5217 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5218             }
5219             elsif (not $octet{')'}) {
5220 0           return join '', $ope, '(', $string, ')';
5221             }
5222             elsif (not $octet{'}'}) {
5223 0           return join '', $ope, '{', $string, '}';
5224             }
5225             elsif (not $octet{']'}) {
5226 0           return join '', $ope, '[', $string, ']';
5227             }
5228             elsif (not $octet{'>'}) {
5229 0           return join '', $ope, '<', $string, '>';
5230             }
5231             else {
5232 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5233 0 0         if (not $octet{$char}) {
5234 0           return join '', $ope, $char, $string, $char;
5235             }
5236             }
5237             }
5238              
5239             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5240 0           my @string = CORE::split(/\s+/, $string);
5241 0           for my $string (@string) {
5242 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5243 0           for my $octet (@octet) {
5244 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5245 0           $octet = '\\' . $1;
5246             }
5247             }
5248 0           $string = join '', @octet;
5249             }
5250 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5251             }
5252              
5253             #
5254             # escape here document (<<"HEREDOC", <
5255             #
5256             sub e_heredoc {
5257 0     0 0   my($string) = @_;
5258              
5259 0           $slash = 'm//';
5260              
5261 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5262              
5263 0           my $left_e = 0;
5264 0           my $right_e = 0;
5265 0           my @char = $string =~ /\G(
5266             \\o\{ [0-7]+ \} |
5267             \\x\{ [0-9A-Fa-f]+ \} |
5268             \\N\{ [^0-9\}][^\}]* \} |
5269             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5270             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5271             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5272             \$ \s* \d+ |
5273             \$ \s* \{ \s* \d+ \s* \} |
5274             \$ \$ (?![\w\{]) |
5275             \$ \s* \$ \s* $qq_variable |
5276             \\?(?:$q_char)
5277             )/oxmsg;
5278              
5279 0           for (my $i=0; $i <= $#char; $i++) {
5280              
5281             # "\L\u" --> "\u\L"
5282 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5283 0           @char[$i,$i+1] = @char[$i+1,$i];
5284             }
5285              
5286             # "\U\l" --> "\l\U"
5287             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5288 0           @char[$i,$i+1] = @char[$i+1,$i];
5289             }
5290              
5291             # octal escape sequence
5292             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5293 0           $char[$i] = Char::Elatin10::octchr($1);
5294             }
5295              
5296             # hexadecimal escape sequence
5297             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5298 0           $char[$i] = Char::Elatin10::hexchr($1);
5299             }
5300              
5301             # \N{CHARNAME} --> N{CHARNAME}
5302             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5303 0           $char[$i] = $1;
5304             }
5305              
5306 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          
5307             }
5308              
5309             # \u \l \U \L \F \Q \E
5310 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5311 0 0         if ($right_e < $left_e) {
5312 0           $char[$i] = '\\' . $char[$i];
5313             }
5314             }
5315             elsif ($char[$i] eq '\u') {
5316 0           $char[$i] = '@{[Char::Elatin10::ucfirst qq<';
5317 0           $left_e++;
5318             }
5319             elsif ($char[$i] eq '\l') {
5320 0           $char[$i] = '@{[Char::Elatin10::lcfirst qq<';
5321 0           $left_e++;
5322             }
5323             elsif ($char[$i] eq '\U') {
5324 0           $char[$i] = '@{[Char::Elatin10::uc qq<';
5325 0           $left_e++;
5326             }
5327             elsif ($char[$i] eq '\L') {
5328 0           $char[$i] = '@{[Char::Elatin10::lc qq<';
5329 0           $left_e++;
5330             }
5331             elsif ($char[$i] eq '\F') {
5332 0           $char[$i] = '@{[Char::Elatin10::fc qq<';
5333 0           $left_e++;
5334             }
5335             elsif ($char[$i] eq '\Q') {
5336 0           $char[$i] = '@{[CORE::quotemeta qq<';
5337 0           $left_e++;
5338             }
5339             elsif ($char[$i] eq '\E') {
5340 0 0         if ($right_e < $left_e) {
5341 0           $char[$i] = '>]}';
5342 0           $right_e++;
5343             }
5344             else {
5345 0           $char[$i] = '';
5346             }
5347             }
5348             elsif ($char[$i] eq '\Q') {
5349 0           while (1) {
5350 0 0         if (++$i > $#char) {
5351 0           last;
5352             }
5353 0 0         if ($char[$i] eq '\E') {
5354 0           last;
5355             }
5356             }
5357             }
5358             elsif ($char[$i] eq '\E') {
5359             }
5360              
5361             # $0 --> $0
5362             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5363             }
5364             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5365             }
5366              
5367             # $$ --> $$
5368             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5369             }
5370              
5371             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5372             # $1, $2, $3 --> $1, $2, $3 otherwise
5373             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5374 0           $char[$i] = e_capture($1);
5375             }
5376             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5377 0           $char[$i] = e_capture($1);
5378             }
5379              
5380             # $$foo[ ... ] --> $ $foo->[ ... ]
5381             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5382 0           $char[$i] = e_capture($1.'->'.$2);
5383             }
5384              
5385             # $$foo{ ... } --> $ $foo->{ ... }
5386             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5387 0           $char[$i] = e_capture($1.'->'.$2);
5388             }
5389              
5390             # $$foo
5391             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5392 0           $char[$i] = e_capture($1);
5393             }
5394              
5395             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin10::PREMATCH()
5396             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5397 0           $char[$i] = '@{[Char::Elatin10::PREMATCH()]}';
5398             }
5399              
5400             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin10::MATCH()
5401             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5402 0           $char[$i] = '@{[Char::Elatin10::MATCH()]}';
5403             }
5404              
5405             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin10::POSTMATCH()
5406             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5407 0           $char[$i] = '@{[Char::Elatin10::POSTMATCH()]}';
5408             }
5409              
5410             # ${ foo } --> ${ foo }
5411             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5412             }
5413              
5414             # ${ ... }
5415             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5416 0           $char[$i] = e_capture($1);
5417             }
5418             }
5419              
5420             # return string
5421 0 0         if ($left_e > $right_e) {
5422 0           return join '', @char, '>]}' x ($left_e - $right_e);
5423             }
5424 0           return join '', @char;
5425             }
5426              
5427             #
5428             # escape regexp (m//, qr//)
5429             #
5430             sub e_qr {
5431 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5432 0   0       $modifier ||= '';
5433              
5434 0           $modifier =~ tr/p//d;
5435 0 0         if ($modifier =~ /([adlu])/oxms) {
5436 0           my $line = 0;
5437 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5438 0 0         if ($filename ne __FILE__) {
5439 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5440 0           last;
5441             }
5442             }
5443 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5444             }
5445              
5446 0           $slash = 'div';
5447              
5448             # literal null string pattern
5449 0 0         if ($string eq '') {
    0          
5450 0           $modifier =~ tr/bB//d;
5451 0           $modifier =~ tr/i//d;
5452 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5453             }
5454              
5455             # /b /B modifier
5456             elsif ($modifier =~ tr/bB//d) {
5457              
5458             # choice again delimiter
5459 0 0         if ($delimiter =~ / [\@:] /oxms) {
5460 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5461 0           my %octet = map {$_ => 1} @char;
  0            
5462 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5463 0           $delimiter = '(';
5464 0           $end_delimiter = ')';
5465             }
5466             elsif (not $octet{'}'}) {
5467 0           $delimiter = '{';
5468 0           $end_delimiter = '}';
5469             }
5470             elsif (not $octet{']'}) {
5471 0           $delimiter = '[';
5472 0           $end_delimiter = ']';
5473             }
5474             elsif (not $octet{'>'}) {
5475 0           $delimiter = '<';
5476 0           $end_delimiter = '>';
5477             }
5478             else {
5479 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5480 0 0         if (not $octet{$char}) {
5481 0           $delimiter = $char;
5482 0           $end_delimiter = $char;
5483 0           last;
5484             }
5485             }
5486             }
5487             }
5488              
5489 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5490 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5491             }
5492             else {
5493 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5494             }
5495             }
5496              
5497 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5498 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5499              
5500             # split regexp
5501 0           my @char = $string =~ /\G(
5502             \\o\{ [0-7]+ \} |
5503             \\ [0-7]{2,3} |
5504             \\x\{ [0-9A-Fa-f]+ \} |
5505             \\x [0-9A-Fa-f]{1,2} |
5506             \\c [\x40-\x5F] |
5507             \\N\{ [^0-9\}][^\}]* \} |
5508             \\p\{ [^0-9\}][^\}]* \} |
5509             \\P\{ [^0-9\}][^\}]* \} |
5510             \\ (?:$q_char) |
5511             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5512             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5513             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5514             [\$\@] $qq_variable |
5515             \$ \s* \d+ |
5516             \$ \s* \{ \s* \d+ \s* \} |
5517             \$ \$ (?![\w\{]) |
5518             \$ \s* \$ \s* $qq_variable |
5519             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5520             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5521             \[\^ |
5522             \(\? |
5523             (?:$q_char)
5524             )/oxmsg;
5525              
5526             # choice again delimiter
5527 0 0         if ($delimiter =~ / [\@:] /oxms) {
5528 0           my %octet = map {$_ => 1} @char;
  0            
5529 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5530 0           $delimiter = '(';
5531 0           $end_delimiter = ')';
5532             }
5533             elsif (not $octet{'}'}) {
5534 0           $delimiter = '{';
5535 0           $end_delimiter = '}';
5536             }
5537             elsif (not $octet{']'}) {
5538 0           $delimiter = '[';
5539 0           $end_delimiter = ']';
5540             }
5541             elsif (not $octet{'>'}) {
5542 0           $delimiter = '<';
5543 0           $end_delimiter = '>';
5544             }
5545             else {
5546 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5547 0 0         if (not $octet{$char}) {
5548 0           $delimiter = $char;
5549 0           $end_delimiter = $char;
5550 0           last;
5551             }
5552             }
5553             }
5554             }
5555              
5556 0           my $left_e = 0;
5557 0           my $right_e = 0;
5558 0           for (my $i=0; $i <= $#char; $i++) {
5559              
5560             # "\L\u" --> "\u\L"
5561 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
5562 0           @char[$i,$i+1] = @char[$i+1,$i];
5563             }
5564              
5565             # "\U\l" --> "\l\U"
5566             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5567 0           @char[$i,$i+1] = @char[$i+1,$i];
5568             }
5569              
5570             # octal escape sequence
5571             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5572 0           $char[$i] = Char::Elatin10::octchr($1);
5573             }
5574              
5575             # hexadecimal escape sequence
5576             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5577 0           $char[$i] = Char::Elatin10::hexchr($1);
5578             }
5579              
5580             # \N{CHARNAME} --> N\{CHARNAME}
5581             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5582 0           $char[$i] = $1 . '\\' . $2;
5583             }
5584              
5585             # \p{PROPERTY} --> p\{PROPERTY}
5586             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5587 0           $char[$i] = $1 . '\\' . $2;
5588             }
5589              
5590             # \P{PROPERTY} --> P\{PROPERTY}
5591             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5592 0           $char[$i] = $1 . '\\' . $2;
5593             }
5594              
5595             # \p, \P, \X --> p, P, X
5596             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5597 0           $char[$i] = $1;
5598             }
5599              
5600 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          
5601             }
5602              
5603             # join separated multiple-octet
5604 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5605 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        
5606 0           $char[$i] .= join '', splice @char, $i+1, 3;
5607             }
5608             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)) {
5609 0           $char[$i] .= join '', splice @char, $i+1, 2;
5610             }
5611             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)) {
5612 0           $char[$i] .= join '', splice @char, $i+1, 1;
5613             }
5614             }
5615              
5616             # open character class [...]
5617             elsif ($char[$i] eq '[') {
5618 0           my $left = $i;
5619              
5620             # [] make die "Unmatched [] in regexp ..."
5621             # (and so on)
5622              
5623 0 0         if ($char[$i+1] eq ']') {
5624 0           $i++;
5625             }
5626              
5627 0           while (1) {
5628 0 0         if (++$i > $#char) {
5629 0           die __FILE__, ": Unmatched [] in regexp";
5630             }
5631 0 0         if ($char[$i] eq ']') {
5632 0           my $right = $i;
5633              
5634             # [...]
5635 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5636 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5637             }
5638             else {
5639 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5640             }
5641              
5642 0           $i = $left;
5643 0           last;
5644             }
5645             }
5646             }
5647              
5648             # open character class [^...]
5649             elsif ($char[$i] eq '[^') {
5650 0           my $left = $i;
5651              
5652             # [^] make die "Unmatched [] in regexp ..."
5653             # (and so on)
5654              
5655 0 0         if ($char[$i+1] eq ']') {
5656 0           $i++;
5657             }
5658              
5659 0           while (1) {
5660 0 0         if (++$i > $#char) {
5661 0           die __FILE__, ": Unmatched [] in regexp";
5662             }
5663 0 0         if ($char[$i] eq ']') {
5664 0           my $right = $i;
5665              
5666             # [^...]
5667 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5668 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5669             }
5670             else {
5671 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5672             }
5673              
5674 0           $i = $left;
5675 0           last;
5676             }
5677             }
5678             }
5679              
5680             # rewrite character class or escape character
5681             elsif (my $char = character_class($char[$i],$modifier)) {
5682 0           $char[$i] = $char;
5683             }
5684              
5685             # /i modifier
5686             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin10::uc($char[$i]) ne Char::Elatin10::fc($char[$i]))) {
5687 0 0         if (CORE::length(Char::Elatin10::fc($char[$i])) == 1) {
5688 0           $char[$i] = '[' . Char::Elatin10::uc($char[$i]) . Char::Elatin10::fc($char[$i]) . ']';
5689             }
5690             else {
5691 0           $char[$i] = '(?:' . Char::Elatin10::uc($char[$i]) . '|' . Char::Elatin10::fc($char[$i]) . ')';
5692             }
5693             }
5694              
5695             # \u \l \U \L \F \Q \E
5696             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5697 0 0         if ($right_e < $left_e) {
5698 0           $char[$i] = '\\' . $char[$i];
5699             }
5700             }
5701             elsif ($char[$i] eq '\u') {
5702 0           $char[$i] = '@{[Char::Elatin10::ucfirst qq<';
5703 0           $left_e++;
5704             }
5705             elsif ($char[$i] eq '\l') {
5706 0           $char[$i] = '@{[Char::Elatin10::lcfirst qq<';
5707 0           $left_e++;
5708             }
5709             elsif ($char[$i] eq '\U') {
5710 0           $char[$i] = '@{[Char::Elatin10::uc qq<';
5711 0           $left_e++;
5712             }
5713             elsif ($char[$i] eq '\L') {
5714 0           $char[$i] = '@{[Char::Elatin10::lc qq<';
5715 0           $left_e++;
5716             }
5717             elsif ($char[$i] eq '\F') {
5718 0           $char[$i] = '@{[Char::Elatin10::fc qq<';
5719 0           $left_e++;
5720             }
5721             elsif ($char[$i] eq '\Q') {
5722 0           $char[$i] = '@{[CORE::quotemeta qq<';
5723 0           $left_e++;
5724             }
5725             elsif ($char[$i] eq '\E') {
5726 0 0         if ($right_e < $left_e) {
5727 0           $char[$i] = '>]}';
5728 0           $right_e++;
5729             }
5730             else {
5731 0           $char[$i] = '';
5732             }
5733             }
5734             elsif ($char[$i] eq '\Q') {
5735 0           while (1) {
5736 0 0         if (++$i > $#char) {
5737 0           last;
5738             }
5739 0 0         if ($char[$i] eq '\E') {
5740 0           last;
5741             }
5742             }
5743             }
5744             elsif ($char[$i] eq '\E') {
5745             }
5746              
5747             # $0 --> $0
5748             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5749 0 0         if ($ignorecase) {
5750 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5751             }
5752             }
5753             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5754 0 0         if ($ignorecase) {
5755 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5756             }
5757             }
5758              
5759             # $$ --> $$
5760             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5761             }
5762              
5763             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5764             # $1, $2, $3 --> $1, $2, $3 otherwise
5765             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5766 0           $char[$i] = e_capture($1);
5767 0 0         if ($ignorecase) {
5768 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5769             }
5770             }
5771             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5772 0           $char[$i] = e_capture($1);
5773 0 0         if ($ignorecase) {
5774 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5775             }
5776             }
5777              
5778             # $$foo[ ... ] --> $ $foo->[ ... ]
5779             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5780 0           $char[$i] = e_capture($1.'->'.$2);
5781 0 0         if ($ignorecase) {
5782 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5783             }
5784             }
5785              
5786             # $$foo{ ... } --> $ $foo->{ ... }
5787             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5788 0           $char[$i] = e_capture($1.'->'.$2);
5789 0 0         if ($ignorecase) {
5790 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5791             }
5792             }
5793              
5794             # $$foo
5795             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5796 0           $char[$i] = e_capture($1);
5797 0 0         if ($ignorecase) {
5798 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5799             }
5800             }
5801              
5802             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin10::PREMATCH()
5803             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5804 0 0         if ($ignorecase) {
5805 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::PREMATCH())]}';
5806             }
5807             else {
5808 0           $char[$i] = '@{[Char::Elatin10::PREMATCH()]}';
5809             }
5810             }
5811              
5812             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin10::MATCH()
5813             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5814 0 0         if ($ignorecase) {
5815 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::MATCH())]}';
5816             }
5817             else {
5818 0           $char[$i] = '@{[Char::Elatin10::MATCH()]}';
5819             }
5820             }
5821              
5822             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin10::POSTMATCH()
5823             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5824 0 0         if ($ignorecase) {
5825 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::POSTMATCH())]}';
5826             }
5827             else {
5828 0           $char[$i] = '@{[Char::Elatin10::POSTMATCH()]}';
5829             }
5830             }
5831              
5832             # ${ foo }
5833             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5834 0 0         if ($ignorecase) {
5835 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5836             }
5837             }
5838              
5839             # ${ ... }
5840             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5841 0           $char[$i] = e_capture($1);
5842 0 0         if ($ignorecase) {
5843 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5844             }
5845             }
5846              
5847             # $scalar or @array
5848             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5849 0           $char[$i] = e_string($char[$i]);
5850 0 0         if ($ignorecase) {
5851 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
5852             }
5853             }
5854              
5855             # quote character before ? + * {
5856             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5857 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5858             }
5859             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5860 0           my $char = $char[$i-1];
5861 0 0         if ($char[$i] eq '{') {
5862 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
5863             }
5864             else {
5865 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
5866             }
5867             }
5868             else {
5869 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5870             }
5871             }
5872             }
5873              
5874             # make regexp string
5875 0           $modifier =~ tr/i//d;
5876 0 0         if ($left_e > $right_e) {
5877 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5878 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5879             }
5880             else {
5881 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5882             }
5883             }
5884 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5885 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5886             }
5887             else {
5888 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5889             }
5890             }
5891              
5892             #
5893             # double quote stuff
5894             #
5895             sub qq_stuff {
5896 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5897              
5898             # scalar variable or array variable
5899 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5900 0           return $stuff;
5901             }
5902              
5903             # quote by delimiter
5904 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5905 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5906 0 0         next if $char eq $delimiter;
5907 0 0         next if $char eq $end_delimiter;
5908 0 0         if (not $octet{$char}) {
5909 0           return join '', 'qq', $char, $stuff, $char;
5910             }
5911             }
5912 0           return join '', 'qq', '<', $stuff, '>';
5913             }
5914              
5915             #
5916             # escape regexp (m'', qr'', and m''b, qr''b)
5917             #
5918             sub e_qr_q {
5919 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5920 0   0       $modifier ||= '';
5921              
5922 0           $modifier =~ tr/p//d;
5923 0 0         if ($modifier =~ /([adlu])/oxms) {
5924 0           my $line = 0;
5925 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5926 0 0         if ($filename ne __FILE__) {
5927 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5928 0           last;
5929             }
5930             }
5931 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5932             }
5933              
5934 0           $slash = 'div';
5935              
5936             # literal null string pattern
5937 0 0         if ($string eq '') {
    0          
5938 0           $modifier =~ tr/bB//d;
5939 0           $modifier =~ tr/i//d;
5940 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5941             }
5942              
5943             # with /b /B modifier
5944             elsif ($modifier =~ tr/bB//d) {
5945 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5946             }
5947              
5948             # without /b /B modifier
5949             else {
5950 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5951             }
5952             }
5953              
5954             #
5955             # escape regexp (m'', qr'')
5956             #
5957             sub e_qr_qt {
5958 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5959              
5960 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5961              
5962             # split regexp
5963 0           my @char = $string =~ /\G(
5964             \[\:\^ [a-z]+ \:\] |
5965             \[\: [a-z]+ \:\] |
5966             \[\^ |
5967             [\$\@\/\\] |
5968             \\? (?:$q_char)
5969             )/oxmsg;
5970              
5971             # unescape character
5972 0           for (my $i=0; $i <= $#char; $i++) {
5973 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5974             }
5975              
5976             # open character class [...]
5977 0           elsif ($char[$i] eq '[') {
5978 0           my $left = $i;
5979 0 0         if ($char[$i+1] eq ']') {
5980 0           $i++;
5981             }
5982 0           while (1) {
5983 0 0         if (++$i > $#char) {
5984 0           die __FILE__, ": Unmatched [] in regexp";
5985             }
5986 0 0         if ($char[$i] eq ']') {
5987 0           my $right = $i;
5988              
5989             # [...]
5990 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
5991              
5992 0           $i = $left;
5993 0           last;
5994             }
5995             }
5996             }
5997              
5998             # open character class [^...]
5999             elsif ($char[$i] eq '[^') {
6000 0           my $left = $i;
6001 0 0         if ($char[$i+1] eq ']') {
6002 0           $i++;
6003             }
6004 0           while (1) {
6005 0 0         if (++$i > $#char) {
6006 0           die __FILE__, ": Unmatched [] in regexp";
6007             }
6008 0 0         if ($char[$i] eq ']') {
6009 0           my $right = $i;
6010              
6011             # [^...]
6012 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6013              
6014 0           $i = $left;
6015 0           last;
6016             }
6017             }
6018             }
6019              
6020             # escape $ @ / and \
6021             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6022 0           $char[$i] = '\\' . $char[$i];
6023             }
6024              
6025             # rewrite character class or escape character
6026             elsif (my $char = character_class($char[$i],$modifier)) {
6027 0           $char[$i] = $char;
6028             }
6029              
6030             # /i modifier
6031             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin10::uc($char[$i]) ne Char::Elatin10::fc($char[$i]))) {
6032 0 0         if (CORE::length(Char::Elatin10::fc($char[$i])) == 1) {
6033 0           $char[$i] = '[' . Char::Elatin10::uc($char[$i]) . Char::Elatin10::fc($char[$i]) . ']';
6034             }
6035             else {
6036 0           $char[$i] = '(?:' . Char::Elatin10::uc($char[$i]) . '|' . Char::Elatin10::fc($char[$i]) . ')';
6037             }
6038             }
6039              
6040             # quote character before ? + * {
6041             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6042 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6043             }
6044             else {
6045 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6046             }
6047             }
6048             }
6049              
6050 0           $delimiter = '/';
6051 0           $end_delimiter = '/';
6052              
6053 0           $modifier =~ tr/i//d;
6054 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6055             }
6056              
6057             #
6058             # escape regexp (m''b, qr''b)
6059             #
6060             sub e_qr_qb {
6061 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6062              
6063             # split regexp
6064 0           my @char = $string =~ /\G(
6065             \\\\ |
6066             [\$\@\/\\] |
6067             [\x00-\xFF]
6068             )/oxmsg;
6069              
6070             # unescape character
6071 0           for (my $i=0; $i <= $#char; $i++) {
6072 0 0         if (0) {
    0          
6073             }
6074              
6075             # remain \\
6076 0           elsif ($char[$i] eq '\\\\') {
6077             }
6078              
6079             # escape $ @ / and \
6080             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6081 0           $char[$i] = '\\' . $char[$i];
6082             }
6083             }
6084              
6085 0           $delimiter = '/';
6086 0           $end_delimiter = '/';
6087 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6088             }
6089              
6090             #
6091             # escape regexp (s/here//)
6092             #
6093             sub e_s1 {
6094 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6095 0   0       $modifier ||= '';
6096              
6097 0           $modifier =~ tr/p//d;
6098 0 0         if ($modifier =~ /([adlu])/oxms) {
6099 0           my $line = 0;
6100 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6101 0 0         if ($filename ne __FILE__) {
6102 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6103 0           last;
6104             }
6105             }
6106 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6107             }
6108              
6109 0           $slash = 'div';
6110              
6111             # literal null string pattern
6112 0 0         if ($string eq '') {
    0          
6113 0           $modifier =~ tr/bB//d;
6114 0           $modifier =~ tr/i//d;
6115 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6116             }
6117              
6118             # /b /B modifier
6119             elsif ($modifier =~ tr/bB//d) {
6120              
6121             # choice again delimiter
6122 0 0         if ($delimiter =~ / [\@:] /oxms) {
6123 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
6124 0           my %octet = map {$_ => 1} @char;
  0            
6125 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6126 0           $delimiter = '(';
6127 0           $end_delimiter = ')';
6128             }
6129             elsif (not $octet{'}'}) {
6130 0           $delimiter = '{';
6131 0           $end_delimiter = '}';
6132             }
6133             elsif (not $octet{']'}) {
6134 0           $delimiter = '[';
6135 0           $end_delimiter = ']';
6136             }
6137             elsif (not $octet{'>'}) {
6138 0           $delimiter = '<';
6139 0           $end_delimiter = '>';
6140             }
6141             else {
6142 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6143 0 0         if (not $octet{$char}) {
6144 0           $delimiter = $char;
6145 0           $end_delimiter = $char;
6146 0           last;
6147             }
6148             }
6149             }
6150             }
6151              
6152 0           my $prematch = '';
6153 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6154             }
6155              
6156 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6157 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6158              
6159             # split regexp
6160 0           my @char = $string =~ /\G(
6161             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
6162             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
6163             \\g \s* [1-9][0-9]* |
6164             \\o\{ [0-7]+ \} |
6165             \\ [1-9][0-9]* |
6166             \\ [0-7]{2,3} |
6167             \\x\{ [0-9A-Fa-f]+ \} |
6168             \\x [0-9A-Fa-f]{1,2} |
6169             \\c [\x40-\x5F] |
6170             \\N\{ [^0-9\}][^\}]* \} |
6171             \\p\{ [^0-9\}][^\}]* \} |
6172             \\P\{ [^0-9\}][^\}]* \} |
6173             \\ (?:$q_char) |
6174             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6175             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6176             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6177             [\$\@] $qq_variable |
6178             \$ \s* \d+ |
6179             \$ \s* \{ \s* \d+ \s* \} |
6180             \$ \$ (?![\w\{]) |
6181             \$ \s* \$ \s* $qq_variable |
6182             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6183             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6184             \[\^ |
6185             \(\? |
6186             (?:$q_char)
6187             )/oxmsg;
6188              
6189             # choice again delimiter
6190 0 0         if ($delimiter =~ / [\@:] /oxms) {
6191 0           my %octet = map {$_ => 1} @char;
  0            
6192 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6193 0           $delimiter = '(';
6194 0           $end_delimiter = ')';
6195             }
6196             elsif (not $octet{'}'}) {
6197 0           $delimiter = '{';
6198 0           $end_delimiter = '}';
6199             }
6200             elsif (not $octet{']'}) {
6201 0           $delimiter = '[';
6202 0           $end_delimiter = ']';
6203             }
6204             elsif (not $octet{'>'}) {
6205 0           $delimiter = '<';
6206 0           $end_delimiter = '>';
6207             }
6208             else {
6209 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6210 0 0         if (not $octet{$char}) {
6211 0           $delimiter = $char;
6212 0           $end_delimiter = $char;
6213 0           last;
6214             }
6215             }
6216             }
6217             }
6218              
6219             # count '('
6220 0           my $parens = grep { $_ eq '(' } @char;
  0            
6221              
6222 0           my $left_e = 0;
6223 0           my $right_e = 0;
6224 0           for (my $i=0; $i <= $#char; $i++) {
6225              
6226             # "\L\u" --> "\u\L"
6227 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6228 0           @char[$i,$i+1] = @char[$i+1,$i];
6229             }
6230              
6231             # "\U\l" --> "\l\U"
6232             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6233 0           @char[$i,$i+1] = @char[$i+1,$i];
6234             }
6235              
6236             # octal escape sequence
6237             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6238 0           $char[$i] = Char::Elatin10::octchr($1);
6239             }
6240              
6241             # hexadecimal escape sequence
6242             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6243 0           $char[$i] = Char::Elatin10::hexchr($1);
6244             }
6245              
6246             # \N{CHARNAME} --> N\{CHARNAME}
6247             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6248 0           $char[$i] = $1 . '\\' . $2;
6249             }
6250              
6251             # \p{PROPERTY} --> p\{PROPERTY}
6252             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6253 0           $char[$i] = $1 . '\\' . $2;
6254             }
6255              
6256             # \P{PROPERTY} --> P\{PROPERTY}
6257             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6258 0           $char[$i] = $1 . '\\' . $2;
6259             }
6260              
6261             # \p, \P, \X --> p, P, X
6262             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6263 0           $char[$i] = $1;
6264             }
6265              
6266 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          
6267             }
6268              
6269             # join separated multiple-octet
6270 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6271 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        
6272 0           $char[$i] .= join '', splice @char, $i+1, 3;
6273             }
6274             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)) {
6275 0           $char[$i] .= join '', splice @char, $i+1, 2;
6276             }
6277             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)) {
6278 0           $char[$i] .= join '', splice @char, $i+1, 1;
6279             }
6280             }
6281              
6282             # open character class [...]
6283             elsif ($char[$i] eq '[') {
6284 0           my $left = $i;
6285 0 0         if ($char[$i+1] eq ']') {
6286 0           $i++;
6287             }
6288 0           while (1) {
6289 0 0         if (++$i > $#char) {
6290 0           die __FILE__, ": Unmatched [] in regexp";
6291             }
6292 0 0         if ($char[$i] eq ']') {
6293 0           my $right = $i;
6294              
6295             # [...]
6296 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6297 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6298             }
6299             else {
6300 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6301             }
6302              
6303 0           $i = $left;
6304 0           last;
6305             }
6306             }
6307             }
6308              
6309             # open character class [^...]
6310             elsif ($char[$i] eq '[^') {
6311 0           my $left = $i;
6312 0 0         if ($char[$i+1] eq ']') {
6313 0           $i++;
6314             }
6315 0           while (1) {
6316 0 0         if (++$i > $#char) {
6317 0           die __FILE__, ": Unmatched [] in regexp";
6318             }
6319 0 0         if ($char[$i] eq ']') {
6320 0           my $right = $i;
6321              
6322             # [^...]
6323 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6324 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6325             }
6326             else {
6327 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6328             }
6329              
6330 0           $i = $left;
6331 0           last;
6332             }
6333             }
6334             }
6335              
6336             # rewrite character class or escape character
6337             elsif (my $char = character_class($char[$i],$modifier)) {
6338 0           $char[$i] = $char;
6339             }
6340              
6341             # /i modifier
6342             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin10::uc($char[$i]) ne Char::Elatin10::fc($char[$i]))) {
6343 0 0         if (CORE::length(Char::Elatin10::fc($char[$i])) == 1) {
6344 0           $char[$i] = '[' . Char::Elatin10::uc($char[$i]) . Char::Elatin10::fc($char[$i]) . ']';
6345             }
6346             else {
6347 0           $char[$i] = '(?:' . Char::Elatin10::uc($char[$i]) . '|' . Char::Elatin10::fc($char[$i]) . ')';
6348             }
6349             }
6350              
6351             # \u \l \U \L \F \Q \E
6352             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6353 0 0         if ($right_e < $left_e) {
6354 0           $char[$i] = '\\' . $char[$i];
6355             }
6356             }
6357             elsif ($char[$i] eq '\u') {
6358 0           $char[$i] = '@{[Char::Elatin10::ucfirst qq<';
6359 0           $left_e++;
6360             }
6361             elsif ($char[$i] eq '\l') {
6362 0           $char[$i] = '@{[Char::Elatin10::lcfirst qq<';
6363 0           $left_e++;
6364             }
6365             elsif ($char[$i] eq '\U') {
6366 0           $char[$i] = '@{[Char::Elatin10::uc qq<';
6367 0           $left_e++;
6368             }
6369             elsif ($char[$i] eq '\L') {
6370 0           $char[$i] = '@{[Char::Elatin10::lc qq<';
6371 0           $left_e++;
6372             }
6373             elsif ($char[$i] eq '\F') {
6374 0           $char[$i] = '@{[Char::Elatin10::fc qq<';
6375 0           $left_e++;
6376             }
6377             elsif ($char[$i] eq '\Q') {
6378 0           $char[$i] = '@{[CORE::quotemeta qq<';
6379 0           $left_e++;
6380             }
6381             elsif ($char[$i] eq '\E') {
6382 0 0         if ($right_e < $left_e) {
6383 0           $char[$i] = '>]}';
6384 0           $right_e++;
6385             }
6386             else {
6387 0           $char[$i] = '';
6388             }
6389             }
6390             elsif ($char[$i] eq '\Q') {
6391 0           while (1) {
6392 0 0         if (++$i > $#char) {
6393 0           last;
6394             }
6395 0 0         if ($char[$i] eq '\E') {
6396 0           last;
6397             }
6398             }
6399             }
6400             elsif ($char[$i] eq '\E') {
6401             }
6402              
6403             # \0 --> \0
6404             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
6405             }
6406              
6407             # \g{N}, \g{-N}
6408              
6409             # P.108 Using Simple Patterns
6410             # in Chapter 7: In the World of Regular Expressions
6411             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6412              
6413             # P.221 Capturing
6414             # in Chapter 5: Pattern Matching
6415             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6416              
6417             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6418             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6419             }
6420              
6421             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6422             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6423             }
6424              
6425             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6426             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
6427             }
6428              
6429             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6430             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
6431             }
6432              
6433             # $0 --> $0
6434             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6435 0 0         if ($ignorecase) {
6436 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6437             }
6438             }
6439             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
6440 0 0         if ($ignorecase) {
6441 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6442             }
6443             }
6444              
6445             # $$ --> $$
6446             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6447             }
6448              
6449             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6450             # $1, $2, $3 --> $1, $2, $3 otherwise
6451             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
6452 0           $char[$i] = e_capture($1);
6453 0 0         if ($ignorecase) {
6454 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6455             }
6456             }
6457             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6458 0           $char[$i] = e_capture($1);
6459 0 0         if ($ignorecase) {
6460 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6461             }
6462             }
6463              
6464             # $$foo[ ... ] --> $ $foo->[ ... ]
6465             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6466 0           $char[$i] = e_capture($1.'->'.$2);
6467 0 0         if ($ignorecase) {
6468 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6469             }
6470             }
6471              
6472             # $$foo{ ... } --> $ $foo->{ ... }
6473             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6474 0           $char[$i] = e_capture($1.'->'.$2);
6475 0 0         if ($ignorecase) {
6476 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6477             }
6478             }
6479              
6480             # $$foo
6481             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
6482 0           $char[$i] = e_capture($1);
6483 0 0         if ($ignorecase) {
6484 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6485             }
6486             }
6487              
6488             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin10::PREMATCH()
6489             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
6490 0 0         if ($ignorecase) {
6491 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::PREMATCH())]}';
6492             }
6493             else {
6494 0           $char[$i] = '@{[Char::Elatin10::PREMATCH()]}';
6495             }
6496             }
6497              
6498             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin10::MATCH()
6499             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
6500 0 0         if ($ignorecase) {
6501 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::MATCH())]}';
6502             }
6503             else {
6504 0           $char[$i] = '@{[Char::Elatin10::MATCH()]}';
6505             }
6506             }
6507              
6508             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin10::POSTMATCH()
6509             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
6510 0 0         if ($ignorecase) {
6511 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::POSTMATCH())]}';
6512             }
6513             else {
6514 0           $char[$i] = '@{[Char::Elatin10::POSTMATCH()]}';
6515             }
6516             }
6517              
6518             # ${ foo }
6519             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
6520 0 0         if ($ignorecase) {
6521 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6522             }
6523             }
6524              
6525             # ${ ... }
6526             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
6527 0           $char[$i] = e_capture($1);
6528 0 0         if ($ignorecase) {
6529 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6530             }
6531             }
6532              
6533             # $scalar or @array
6534             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6535 0           $char[$i] = e_string($char[$i]);
6536 0 0         if ($ignorecase) {
6537 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
6538             }
6539             }
6540              
6541             # quote character before ? + * {
6542             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6543 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6544             }
6545             else {
6546 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6547             }
6548             }
6549             }
6550              
6551             # make regexp string
6552 0           my $prematch = '';
6553 0           $modifier =~ tr/i//d;
6554 0 0         if ($left_e > $right_e) {
6555 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6556             }
6557 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6558             }
6559              
6560             #
6561             # escape regexp (s'here'' or s'here''b)
6562             #
6563             sub e_s1_q {
6564 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6565 0   0       $modifier ||= '';
6566              
6567 0           $modifier =~ tr/p//d;
6568 0 0         if ($modifier =~ /([adlu])/oxms) {
6569 0           my $line = 0;
6570 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6571 0 0         if ($filename ne __FILE__) {
6572 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6573 0           last;
6574             }
6575             }
6576 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6577             }
6578              
6579 0           $slash = 'div';
6580              
6581             # literal null string pattern
6582 0 0         if ($string eq '') {
    0          
6583 0           $modifier =~ tr/bB//d;
6584 0           $modifier =~ tr/i//d;
6585 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6586             }
6587              
6588             # with /b /B modifier
6589             elsif ($modifier =~ tr/bB//d) {
6590 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6591             }
6592              
6593             # without /b /B modifier
6594             else {
6595 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6596             }
6597             }
6598              
6599             #
6600             # escape regexp (s'here'')
6601             #
6602             sub e_s1_qt {
6603 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6604              
6605 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6606              
6607             # split regexp
6608 0           my @char = $string =~ /\G(
6609             \[\:\^ [a-z]+ \:\] |
6610             \[\: [a-z]+ \:\] |
6611             \[\^ |
6612             [\$\@\/\\] |
6613             \\? (?:$q_char)
6614             )/oxmsg;
6615              
6616             # unescape character
6617 0           for (my $i=0; $i <= $#char; $i++) {
6618 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6619             }
6620              
6621             # open character class [...]
6622 0           elsif ($char[$i] eq '[') {
6623 0           my $left = $i;
6624 0 0         if ($char[$i+1] eq ']') {
6625 0           $i++;
6626             }
6627 0           while (1) {
6628 0 0         if (++$i > $#char) {
6629 0           die __FILE__, ": Unmatched [] in regexp";
6630             }
6631 0 0         if ($char[$i] eq ']') {
6632 0           my $right = $i;
6633              
6634             # [...]
6635 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
6636              
6637 0           $i = $left;
6638 0           last;
6639             }
6640             }
6641             }
6642              
6643             # open character class [^...]
6644             elsif ($char[$i] eq '[^') {
6645 0           my $left = $i;
6646 0 0         if ($char[$i+1] eq ']') {
6647 0           $i++;
6648             }
6649 0           while (1) {
6650 0 0         if (++$i > $#char) {
6651 0           die __FILE__, ": Unmatched [] in regexp";
6652             }
6653 0 0         if ($char[$i] eq ']') {
6654 0           my $right = $i;
6655              
6656             # [^...]
6657 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6658              
6659 0           $i = $left;
6660 0           last;
6661             }
6662             }
6663             }
6664              
6665             # escape $ @ / and \
6666             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6667 0           $char[$i] = '\\' . $char[$i];
6668             }
6669              
6670             # rewrite character class or escape character
6671             elsif (my $char = character_class($char[$i],$modifier)) {
6672 0           $char[$i] = $char;
6673             }
6674              
6675             # /i modifier
6676             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin10::uc($char[$i]) ne Char::Elatin10::fc($char[$i]))) {
6677 0 0         if (CORE::length(Char::Elatin10::fc($char[$i])) == 1) {
6678 0           $char[$i] = '[' . Char::Elatin10::uc($char[$i]) . Char::Elatin10::fc($char[$i]) . ']';
6679             }
6680             else {
6681 0           $char[$i] = '(?:' . Char::Elatin10::uc($char[$i]) . '|' . Char::Elatin10::fc($char[$i]) . ')';
6682             }
6683             }
6684              
6685             # quote character before ? + * {
6686             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6687 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6688             }
6689             else {
6690 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6691             }
6692             }
6693             }
6694              
6695 0           $modifier =~ tr/i//d;
6696 0           $delimiter = '/';
6697 0           $end_delimiter = '/';
6698 0           my $prematch = '';
6699 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6700             }
6701              
6702             #
6703             # escape regexp (s'here''b)
6704             #
6705             sub e_s1_qb {
6706 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6707              
6708             # split regexp
6709 0           my @char = $string =~ /\G(
6710             \\\\ |
6711             [\$\@\/\\] |
6712             [\x00-\xFF]
6713             )/oxmsg;
6714              
6715             # unescape character
6716 0           for (my $i=0; $i <= $#char; $i++) {
6717 0 0         if (0) {
    0          
6718             }
6719              
6720             # remain \\
6721 0           elsif ($char[$i] eq '\\\\') {
6722             }
6723              
6724             # escape $ @ / and \
6725             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6726 0           $char[$i] = '\\' . $char[$i];
6727             }
6728             }
6729              
6730 0           $delimiter = '/';
6731 0           $end_delimiter = '/';
6732 0           my $prematch = '';
6733 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6734             }
6735              
6736             #
6737             # escape regexp (s''here')
6738             #
6739             sub e_s2_q {
6740 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6741              
6742 0           $slash = 'div';
6743              
6744 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
6745 0           for (my $i=0; $i <= $#char; $i++) {
6746 0 0         if (0) {
    0          
6747             }
6748              
6749             # not escape \\
6750 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6751             }
6752              
6753             # escape $ @ / and \
6754             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6755 0           $char[$i] = '\\' . $char[$i];
6756             }
6757             }
6758              
6759 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6760             }
6761              
6762             #
6763             # escape regexp (s/here/and here/modifier)
6764             #
6765             sub e_sub {
6766 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6767 0   0       $modifier ||= '';
6768              
6769 0           $modifier =~ tr/p//d;
6770 0 0         if ($modifier =~ /([adlu])/oxms) {
6771 0           my $line = 0;
6772 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6773 0 0         if ($filename ne __FILE__) {
6774 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6775 0           last;
6776             }
6777             }
6778 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6779             }
6780              
6781 0 0         if ($variable eq '') {
6782 0           $variable = '$_';
6783 0           $bind_operator = ' =~ ';
6784             }
6785              
6786 0           $slash = 'div';
6787              
6788             # P.128 Start of match (or end of previous match): \G
6789             # P.130 Advanced Use of \G with Perl
6790             # in Chapter 3: Overview of Regular Expression Features and Flavors
6791             # P.312 Iterative Matching: Scalar Context, with /g
6792             # in Chapter 7: Perl
6793             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6794              
6795             # P.181 Where You Left Off: The \G Assertion
6796             # in Chapter 5: Pattern Matching
6797             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6798              
6799             # P.220 Where You Left Off: The \G Assertion
6800             # in Chapter 5: Pattern Matching
6801             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6802              
6803 0           my $e_modifier = $modifier =~ tr/e//d;
6804 0           my $r_modifier = $modifier =~ tr/r//d;
6805              
6806 0           my $my = '';
6807 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
6808 0           $my = $variable;
6809 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
6810 0           $variable =~ s/ = .+ \z//oxms;
6811             }
6812              
6813 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6814 0           $variable_basename =~ s/ \s+ \z//oxms;
6815              
6816             # quote replacement string
6817 0           my $e_replacement = '';
6818 0 0         if ($e_modifier >= 1) {
6819 0           $e_replacement = e_qq('', '', '', $replacement);
6820 0           $e_modifier--;
6821             }
6822             else {
6823 0 0         if ($delimiter2 eq "'") {
6824 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6825             }
6826             else {
6827 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6828             }
6829             }
6830              
6831 0           my $sub = '';
6832              
6833             # with /r
6834 0 0         if ($r_modifier) {
6835 0 0         if (0) {
6836             }
6837              
6838             # s///gr without multibyte anchoring
6839 0           elsif ($modifier =~ /g/oxms) {
6840 0 0         $sub = sprintf(
6841             # 1 2 3 4 5
6842             q,
6843              
6844             $variable, # 1
6845             ($delimiter1 eq "'") ? # 2
6846             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6847             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6848             $s_matched, # 3
6849             $e_replacement, # 4
6850             '$Char::Latin10::re_r=CORE::eval $Char::Latin10::re_r; ' x $e_modifier, # 5
6851             );
6852             }
6853              
6854             # s///r
6855             else {
6856              
6857 0           my $prematch = q{$`};
6858              
6859 0 0         $sub = sprintf(
6860             # 1 2 3 4 5 6 7
6861             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Char::Latin10::re_r=%s; %s"%s$Char::Latin10::re_r$'" } : %s>,
6862              
6863             $variable, # 1
6864             ($delimiter1 eq "'") ? # 2
6865             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6866             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6867             $s_matched, # 3
6868             $e_replacement, # 4
6869             '$Char::Latin10::re_r=CORE::eval $Char::Latin10::re_r; ' x $e_modifier, # 5
6870             $prematch, # 6
6871             $variable, # 7
6872             );
6873             }
6874              
6875             # $var !~ s///r doesn't make sense
6876 0 0         if ($bind_operator =~ / !~ /oxms) {
6877 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6878             }
6879             }
6880              
6881             # without /r
6882             else {
6883 0 0         if (0) {
6884             }
6885              
6886             # s///g without multibyte anchoring
6887 0           elsif ($modifier =~ /g/oxms) {
6888 0 0         $sub = sprintf(
    0          
6889             # 1 2 3 4 5 6 7 8
6890             q,
6891              
6892             $variable, # 1
6893             ($delimiter1 eq "'") ? # 2
6894             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6895             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6896             $s_matched, # 3
6897             $e_replacement, # 4
6898             '$Char::Latin10::re_r=CORE::eval $Char::Latin10::re_r; ' x $e_modifier, # 5
6899             $variable, # 6
6900             $variable, # 7
6901             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6902             );
6903             }
6904              
6905             # s///
6906             else {
6907              
6908 0           my $prematch = q{$`};
6909              
6910 0 0         $sub = sprintf(
    0          
6911              
6912             ($bind_operator =~ / =~ /oxms) ?
6913              
6914             # 1 2 3 4 5 6 7 8
6915             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Char::Latin10::re_r=%s; %s%s="%s$Char::Latin10::re_r$'"; 1 } : undef> :
6916              
6917             # 1 2 3 4 5 6 7 8
6918             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Char::Latin10::re_r=%s; %s%s="%s$Char::Latin10::re_r$'"; undef }>,
6919              
6920             $variable, # 1
6921             $bind_operator, # 2
6922             ($delimiter1 eq "'") ? # 3
6923             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6924             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6925             $s_matched, # 4
6926             $e_replacement, # 5
6927             '$Char::Latin10::re_r=CORE::eval $Char::Latin10::re_r; ' x $e_modifier, # 6
6928             $variable, # 7
6929             $prematch, # 8
6930             );
6931             }
6932             }
6933              
6934             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6935 0 0         if ($my ne '') {
6936 0           $sub = "($my, $sub)[1]";
6937             }
6938              
6939             # clear s/// variable
6940 0           $sub_variable = '';
6941 0           $bind_operator = '';
6942              
6943 0           return $sub;
6944             }
6945              
6946             #
6947             # escape regexp of split qr//
6948             #
6949             sub e_split {
6950 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6951 0   0       $modifier ||= '';
6952              
6953 0           $modifier =~ tr/p//d;
6954 0 0         if ($modifier =~ /([adlu])/oxms) {
6955 0           my $line = 0;
6956 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6957 0 0         if ($filename ne __FILE__) {
6958 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6959 0           last;
6960             }
6961             }
6962 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6963             }
6964              
6965 0           $slash = 'div';
6966              
6967             # /b /B modifier
6968 0 0         if ($modifier =~ tr/bB//d) {
6969 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6970             }
6971              
6972 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6973 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6974              
6975             # split regexp
6976 0           my @char = $string =~ /\G(
6977             \\o\{ [0-7]+ \} |
6978             \\ [0-7]{2,3} |
6979             \\x\{ [0-9A-Fa-f]+ \} |
6980             \\x [0-9A-Fa-f]{1,2} |
6981             \\c [\x40-\x5F] |
6982             \\N\{ [^0-9\}][^\}]* \} |
6983             \\p\{ [^0-9\}][^\}]* \} |
6984             \\P\{ [^0-9\}][^\}]* \} |
6985             \\ (?:$q_char) |
6986             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6987             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6988             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6989             [\$\@] $qq_variable |
6990             \$ \s* \d+ |
6991             \$ \s* \{ \s* \d+ \s* \} |
6992             \$ \$ (?![\w\{]) |
6993             \$ \s* \$ \s* $qq_variable |
6994             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6995             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6996             \[\^ |
6997             \(\? |
6998             (?:$q_char)
6999             )/oxmsg;
7000              
7001 0           my $left_e = 0;
7002 0           my $right_e = 0;
7003 0           for (my $i=0; $i <= $#char; $i++) {
7004              
7005             # "\L\u" --> "\u\L"
7006 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
7007 0           @char[$i,$i+1] = @char[$i+1,$i];
7008             }
7009              
7010             # "\U\l" --> "\l\U"
7011             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7012 0           @char[$i,$i+1] = @char[$i+1,$i];
7013             }
7014              
7015             # octal escape sequence
7016             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7017 0           $char[$i] = Char::Elatin10::octchr($1);
7018             }
7019              
7020             # hexadecimal escape sequence
7021             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7022 0           $char[$i] = Char::Elatin10::hexchr($1);
7023             }
7024              
7025             # \N{CHARNAME} --> N\{CHARNAME}
7026             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7027 0           $char[$i] = $1 . '\\' . $2;
7028             }
7029              
7030             # \p{PROPERTY} --> p\{PROPERTY}
7031             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7032 0           $char[$i] = $1 . '\\' . $2;
7033             }
7034              
7035             # \P{PROPERTY} --> P\{PROPERTY}
7036             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7037 0           $char[$i] = $1 . '\\' . $2;
7038             }
7039              
7040             # \p, \P, \X --> p, P, X
7041             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7042 0           $char[$i] = $1;
7043             }
7044              
7045 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          
7046             }
7047              
7048             # join separated multiple-octet
7049 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7050 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        
7051 0           $char[$i] .= join '', splice @char, $i+1, 3;
7052             }
7053             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)) {
7054 0           $char[$i] .= join '', splice @char, $i+1, 2;
7055             }
7056             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)) {
7057 0           $char[$i] .= join '', splice @char, $i+1, 1;
7058             }
7059             }
7060              
7061             # open character class [...]
7062             elsif ($char[$i] eq '[') {
7063 0           my $left = $i;
7064 0 0         if ($char[$i+1] eq ']') {
7065 0           $i++;
7066             }
7067 0           while (1) {
7068 0 0         if (++$i > $#char) {
7069 0           die __FILE__, ": Unmatched [] in regexp";
7070             }
7071 0 0         if ($char[$i] eq ']') {
7072 0           my $right = $i;
7073              
7074             # [...]
7075 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7076 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin10::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7077             }
7078             else {
7079 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7080             }
7081              
7082 0           $i = $left;
7083 0           last;
7084             }
7085             }
7086             }
7087              
7088             # open character class [^...]
7089             elsif ($char[$i] eq '[^') {
7090 0           my $left = $i;
7091 0 0         if ($char[$i+1] eq ']') {
7092 0           $i++;
7093             }
7094 0           while (1) {
7095 0 0         if (++$i > $#char) {
7096 0           die __FILE__, ": Unmatched [] in regexp";
7097             }
7098 0 0         if ($char[$i] eq ']') {
7099 0           my $right = $i;
7100              
7101             # [^...]
7102 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7103 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin10::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7104             }
7105             else {
7106 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7107             }
7108              
7109 0           $i = $left;
7110 0           last;
7111             }
7112             }
7113             }
7114              
7115             # rewrite character class or escape character
7116             elsif (my $char = character_class($char[$i],$modifier)) {
7117 0           $char[$i] = $char;
7118             }
7119              
7120             # P.794 29.2.161. split
7121             # in Chapter 29: Functions
7122             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7123              
7124             # P.951 split
7125             # in Chapter 27: Functions
7126             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7127              
7128             # said "The //m modifier is assumed when you split on the pattern /^/",
7129             # but perl5.008 is not so. Therefore, this software adds //m.
7130             # (and so on)
7131              
7132             # split(m/^/) --> split(m/^/m)
7133             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7134 0           $modifier .= 'm';
7135             }
7136              
7137             # /i modifier
7138             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin10::uc($char[$i]) ne Char::Elatin10::fc($char[$i]))) {
7139 0 0         if (CORE::length(Char::Elatin10::fc($char[$i])) == 1) {
7140 0           $char[$i] = '[' . Char::Elatin10::uc($char[$i]) . Char::Elatin10::fc($char[$i]) . ']';
7141             }
7142             else {
7143 0           $char[$i] = '(?:' . Char::Elatin10::uc($char[$i]) . '|' . Char::Elatin10::fc($char[$i]) . ')';
7144             }
7145             }
7146              
7147             # \u \l \U \L \F \Q \E
7148             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7149 0 0         if ($right_e < $left_e) {
7150 0           $char[$i] = '\\' . $char[$i];
7151             }
7152             }
7153             elsif ($char[$i] eq '\u') {
7154 0           $char[$i] = '@{[Char::Elatin10::ucfirst qq<';
7155 0           $left_e++;
7156             }
7157             elsif ($char[$i] eq '\l') {
7158 0           $char[$i] = '@{[Char::Elatin10::lcfirst qq<';
7159 0           $left_e++;
7160             }
7161             elsif ($char[$i] eq '\U') {
7162 0           $char[$i] = '@{[Char::Elatin10::uc qq<';
7163 0           $left_e++;
7164             }
7165             elsif ($char[$i] eq '\L') {
7166 0           $char[$i] = '@{[Char::Elatin10::lc qq<';
7167 0           $left_e++;
7168             }
7169             elsif ($char[$i] eq '\F') {
7170 0           $char[$i] = '@{[Char::Elatin10::fc qq<';
7171 0           $left_e++;
7172             }
7173             elsif ($char[$i] eq '\Q') {
7174 0           $char[$i] = '@{[CORE::quotemeta qq<';
7175 0           $left_e++;
7176             }
7177             elsif ($char[$i] eq '\E') {
7178 0 0         if ($right_e < $left_e) {
7179 0           $char[$i] = '>]}';
7180 0           $right_e++;
7181             }
7182             else {
7183 0           $char[$i] = '';
7184             }
7185             }
7186             elsif ($char[$i] eq '\Q') {
7187 0           while (1) {
7188 0 0         if (++$i > $#char) {
7189 0           last;
7190             }
7191 0 0         if ($char[$i] eq '\E') {
7192 0           last;
7193             }
7194             }
7195             }
7196             elsif ($char[$i] eq '\E') {
7197             }
7198              
7199             # $0 --> $0
7200             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7201 0 0         if ($ignorecase) {
7202 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7203             }
7204             }
7205             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
7206 0 0         if ($ignorecase) {
7207 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7208             }
7209             }
7210              
7211             # $$ --> $$
7212             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7213             }
7214              
7215             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7216             # $1, $2, $3 --> $1, $2, $3 otherwise
7217             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
7218 0           $char[$i] = e_capture($1);
7219 0 0         if ($ignorecase) {
7220 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7221             }
7222             }
7223             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
7224 0           $char[$i] = e_capture($1);
7225 0 0         if ($ignorecase) {
7226 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7227             }
7228             }
7229              
7230             # $$foo[ ... ] --> $ $foo->[ ... ]
7231             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7232 0           $char[$i] = e_capture($1.'->'.$2);
7233 0 0         if ($ignorecase) {
7234 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7235             }
7236             }
7237              
7238             # $$foo{ ... } --> $ $foo->{ ... }
7239             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7240 0           $char[$i] = e_capture($1.'->'.$2);
7241 0 0         if ($ignorecase) {
7242 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7243             }
7244             }
7245              
7246             # $$foo
7247             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
7248 0           $char[$i] = e_capture($1);
7249 0 0         if ($ignorecase) {
7250 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7251             }
7252             }
7253              
7254             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin10::PREMATCH()
7255             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
7256 0 0         if ($ignorecase) {
7257 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::PREMATCH())]}';
7258             }
7259             else {
7260 0           $char[$i] = '@{[Char::Elatin10::PREMATCH()]}';
7261             }
7262             }
7263              
7264             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin10::MATCH()
7265             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
7266 0 0         if ($ignorecase) {
7267 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::MATCH())]}';
7268             }
7269             else {
7270 0           $char[$i] = '@{[Char::Elatin10::MATCH()]}';
7271             }
7272             }
7273              
7274             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin10::POSTMATCH()
7275             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
7276 0 0         if ($ignorecase) {
7277 0           $char[$i] = '@{[Char::Elatin10::ignorecase(Char::Elatin10::POSTMATCH())]}';
7278             }
7279             else {
7280 0           $char[$i] = '@{[Char::Elatin10::POSTMATCH()]}';
7281             }
7282             }
7283              
7284             # ${ foo }
7285             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
7286 0 0         if ($ignorecase) {
7287 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $1 . ')]}';
7288             }
7289             }
7290              
7291             # ${ ... }
7292             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
7293 0           $char[$i] = e_capture($1);
7294 0 0         if ($ignorecase) {
7295 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7296             }
7297             }
7298              
7299             # $scalar or @array
7300             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7301 0           $char[$i] = e_string($char[$i]);
7302 0 0         if ($ignorecase) {
7303 0           $char[$i] = '@{[Char::Elatin10::ignorecase(' . $char[$i] . ')]}';
7304             }
7305             }
7306              
7307             # quote character before ? + * {
7308             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7309 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7310             }
7311             else {
7312 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7313             }
7314             }
7315             }
7316              
7317             # make regexp string
7318 0           $modifier =~ tr/i//d;
7319 0 0         if ($left_e > $right_e) {
7320 0           return join '', 'Char::Elatin10::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7321             }
7322 0           return join '', 'Char::Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7323             }
7324              
7325             #
7326             # escape regexp of split qr''
7327             #
7328             sub e_split_q {
7329 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7330 0   0       $modifier ||= '';
7331              
7332 0           $modifier =~ tr/p//d;
7333 0 0         if ($modifier =~ /([adlu])/oxms) {
7334 0           my $line = 0;
7335 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7336 0 0         if ($filename ne __FILE__) {
7337 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7338 0           last;
7339             }
7340             }
7341 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7342             }
7343              
7344 0           $slash = 'div';
7345              
7346             # /b /B modifier
7347 0 0         if ($modifier =~ tr/bB//d) {
7348 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7349             }
7350              
7351 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7352              
7353             # split regexp
7354 0           my @char = $string =~ /\G(
7355             \[\:\^ [a-z]+ \:\] |
7356             \[\: [a-z]+ \:\] |
7357             \[\^ |
7358             \\? (?:$q_char)
7359             )/oxmsg;
7360              
7361             # unescape character
7362 0           for (my $i=0; $i <= $#char; $i++) {
7363 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7364             }
7365              
7366             # open character class [...]
7367 0           elsif ($char[$i] eq '[') {
7368 0           my $left = $i;
7369 0 0         if ($char[$i+1] eq ']') {
7370 0           $i++;
7371             }
7372 0           while (1) {
7373 0 0         if (++$i > $#char) {
7374 0           die __FILE__, ": Unmatched [] in regexp";
7375             }
7376 0 0         if ($char[$i] eq ']') {
7377 0           my $right = $i;
7378              
7379             # [...]
7380 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_qr(@char[$left+1..$right-1], $modifier);
7381              
7382 0           $i = $left;
7383 0           last;
7384             }
7385             }
7386             }
7387              
7388             # open character class [^...]
7389             elsif ($char[$i] eq '[^') {
7390 0           my $left = $i;
7391 0 0         if ($char[$i+1] eq ']') {
7392 0           $i++;
7393             }
7394 0           while (1) {
7395 0 0         if (++$i > $#char) {
7396 0           die __FILE__, ": Unmatched [] in regexp";
7397             }
7398 0 0         if ($char[$i] eq ']') {
7399 0           my $right = $i;
7400              
7401             # [^...]
7402 0           splice @char, $left, $right-$left+1, Char::Elatin10::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7403              
7404 0           $i = $left;
7405 0           last;
7406             }
7407             }
7408             }
7409              
7410             # rewrite character class or escape character
7411             elsif (my $char = character_class($char[$i],$modifier)) {
7412 0           $char[$i] = $char;
7413             }
7414              
7415             # split(m/^/) --> split(m/^/m)
7416             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7417 0           $modifier .= 'm';
7418             }
7419              
7420             # /i modifier
7421             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin10::uc($char[$i]) ne Char::Elatin10::fc($char[$i]))) {
7422 0 0         if (CORE::length(Char::Elatin10::fc($char[$i])) == 1) {
7423 0           $char[$i] = '[' . Char::Elatin10::uc($char[$i]) . Char::Elatin10::fc($char[$i]) . ']';
7424             }
7425             else {
7426 0           $char[$i] = '(?:' . Char::Elatin10::uc($char[$i]) . '|' . Char::Elatin10::fc($char[$i]) . ')';
7427             }
7428             }
7429              
7430             # quote character before ? + * {
7431             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7432 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7433             }
7434             else {
7435 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7436             }
7437             }
7438             }
7439              
7440 0           $modifier =~ tr/i//d;
7441 0           return join '', 'Char::Elatin10::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7442             }
7443              
7444             #
7445             # instead of Carp::carp
7446             #
7447             sub carp {
7448 0     0 0   my($package,$filename,$line) = caller(1);
7449 0           print STDERR "@_ at $filename line $line.\n";
7450             }
7451              
7452             #
7453             # instead of Carp::croak
7454             #
7455             sub croak {
7456 0     0 0   my($package,$filename,$line) = caller(1);
7457 0           print STDERR "@_ at $filename line $line.\n";
7458 0           die "\n";
7459             }
7460              
7461             #
7462             # instead of Carp::cluck
7463             #
7464             sub cluck {
7465 0     0 0   my $i = 0;
7466 0           my @cluck = ();
7467 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7468 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7469 0           $i++;
7470             }
7471 0           print STDERR CORE::reverse @cluck;
7472 0           print STDERR "\n";
7473 0           carp @_;
7474             }
7475              
7476             #
7477             # instead of Carp::confess
7478             #
7479             sub confess {
7480 0     0 0   my $i = 0;
7481 0           my @confess = ();
7482 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7483 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7484 0           $i++;
7485             }
7486 0           print STDERR CORE::reverse @confess;
7487 0           print STDERR "\n";
7488 0           croak @_;
7489             }
7490              
7491             1;
7492              
7493             __END__