File Coverage

Char/Elatin9.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::Elatin9;
5             ######################################################################
6             #
7             # Char::Elatin9 - Run-time routines for Char/Latin9.pm
8             #
9             # http://search.cpan.org/dist/Char-Latin9/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
12             ######################################################################
13              
14 197     197   4462 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         647  
  197         10855  
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   13658 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1173  
  197         337  
  197         36444  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 197 50   197   1388 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 197         276 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 197         32728 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   13286 CORE::eval q{
  197     197   1260  
  197     62   425  
  197         46742  
  62         10273  
  71         11852  
  69         12794  
  63         11551  
  66         12473  
  63         10051  
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       125163 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   617 my $genpkg = "Symbol::";
62 197         10415 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::Elatin9::index($name, '::') == -1) && (Char::Elatin9::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   452 if (CORE::eval { local $@; CORE::require strict }) {
  197         465  
  197         2091  
110 197         30366 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   13337 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  197     197   1233  
  197         331  
  197         12899  
140 197     197   11864 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  197     197   1126  
  197         312  
  197         13932  
141 197     197   12046 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  197     197   1874  
  197         453  
  197         16047  
142              
143             #
144             # Latin-9 character range per length
145             #
146             my %range_tr = ();
147              
148             #
149             # alias of encoding name
150             #
151 197     197   12223 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  197     197   1136  
  197         331  
  197         426783  
152              
153             #
154             # Latin-9 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 Elatin9 \z/oxms) {
170             %range_tr = (
171             1 => [ [0x00..0xFF],
172             ],
173             );
174             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-15 | iec[- ]?8859-15 | latin-?9 ) \b /oxmsi;
175              
176             %lc = (%lc,
177             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
178             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
179             "\xBC" => "\xBD", # LATIN LIGATURE OE
180             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
181             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
182             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
183             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
184             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
185             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
186             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
187             "\xC6" => "\xE6", # LATIN LETTER AE
188             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
189             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
190             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
191             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
192             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
193             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
194             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
195             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
196             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
197             "\xD0" => "\xF0", # LATIN LETTER ETH
198             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
199             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
200             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
201             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
202             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
203             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
204             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
205             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
206             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
207             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
208             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
209             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
210             "\xDE" => "\xFE", # LATIN LETTER THORN
211             );
212              
213             %uc = (%uc,
214             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
215             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
216             "\xBD" => "\xBC", # LATIN LIGATURE OE
217             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
218             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
219             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
220             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
221             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
222             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
223             "\xE6" => "\xC6", # LATIN LETTER AE
224             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
225             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
226             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
227             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
228             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
229             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
230             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
231             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
232             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
233             "\xF0" => "\xD0", # LATIN LETTER ETH
234             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
235             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
236             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
237             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
238             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
239             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
240             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
241             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
242             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
243             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
244             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
245             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
246             "\xFE" => "\xDE", # LATIN LETTER THORN
247             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
248             );
249              
250             %fc = (%fc,
251             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
252             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
253             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
254             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
255             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
256             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
257             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
258             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
259             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
260             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
261             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
262             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
263             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
264             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
265             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
266             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
267             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
268             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
269             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
270             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
271             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
272             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
273             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
274             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
275             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
276             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
277             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
278             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
279             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
280             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
281             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
282             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
283             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
284             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
285             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
286             );
287             }
288              
289             else {
290             croak "Don't know my package name '@{[__PACKAGE__]}'";
291             }
292              
293             #
294             # @ARGV wildcard globbing
295             #
296             sub import {
297              
298 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
299 0         0 my @argv = ();
300 0         0 for (@ARGV) {
301              
302             # has space
303 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
304 0 0       0 if (my @glob = Char::Elatin9::glob(qq{"$_"})) {
305 0         0 push @argv, @glob;
306             }
307             else {
308 0         0 push @argv, $_;
309             }
310             }
311              
312             # has wildcard metachar
313             elsif (/\A (?:$q_char)*? [*?] /oxms) {
314 0 0       0 if (my @glob = Char::Elatin9::glob($_)) {
315 0         0 push @argv, @glob;
316             }
317             else {
318 0         0 push @argv, $_;
319             }
320             }
321              
322             # no wildcard globbing
323             else {
324 0         0 push @argv, $_;
325             }
326             }
327 0         0 @ARGV = @argv;
328             }
329             }
330              
331             # P.230 Care with Prototypes
332             # in Chapter 6: Subroutines
333             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
334             #
335             # If you aren't careful, you can get yourself into trouble with prototypes.
336             # But if you are careful, you can do a lot of neat things with them. This is
337             # all very powerful, of course, and should only be used in moderation to make
338             # the world a better place.
339              
340             # P.332 Care with Prototypes
341             # in Chapter 7: Subroutines
342             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
343             #
344             # If you aren't careful, you can get yourself into trouble with prototypes.
345             # But if you are careful, you can do a lot of neat things with them. This is
346             # all very powerful, of course, and should only be used in moderation to make
347             # the world a better place.
348              
349             #
350             # Prototypes of subroutines
351             #
352 0     0   0 sub unimport {}
353             sub Char::Elatin9::split(;$$$);
354             sub Char::Elatin9::tr($$$$;$);
355             sub Char::Elatin9::chop(@);
356             sub Char::Elatin9::index($$;$);
357             sub Char::Elatin9::rindex($$;$);
358             sub Char::Elatin9::lcfirst(@);
359             sub Char::Elatin9::lcfirst_();
360             sub Char::Elatin9::lc(@);
361             sub Char::Elatin9::lc_();
362             sub Char::Elatin9::ucfirst(@);
363             sub Char::Elatin9::ucfirst_();
364             sub Char::Elatin9::uc(@);
365             sub Char::Elatin9::uc_();
366             sub Char::Elatin9::fc(@);
367             sub Char::Elatin9::fc_();
368             sub Char::Elatin9::ignorecase;
369             sub Char::Elatin9::classic_character_class;
370             sub Char::Elatin9::capture;
371             sub Char::Elatin9::chr(;$);
372             sub Char::Elatin9::chr_();
373             sub Char::Elatin9::glob($);
374             sub Char::Elatin9::glob_();
375              
376             sub Char::Latin9::ord(;$);
377             sub Char::Latin9::ord_();
378             sub Char::Latin9::reverse(@);
379             sub Char::Latin9::getc(;*@);
380             sub Char::Latin9::length(;$);
381             sub Char::Latin9::substr($$;$$);
382             sub Char::Latin9::index($$;$);
383             sub Char::Latin9::rindex($$;$);
384             sub Char::Latin9::escape(;$);
385              
386             #
387             # Regexp work
388             #
389 197     197   16639 BEGIN { CORE::eval q{ use vars qw(
  197     197   1418  
  197         429  
  197         89793  
390             $Char::Latin9::re_a
391             $Char::Latin9::re_t
392             $Char::Latin9::re_n
393             $Char::Latin9::re_r
394             ) } }
395              
396             #
397             # Character class
398             #
399 197     197   16296 BEGIN { CORE::eval q{ use vars qw(
  197     197   1177  
  197         326  
  197         3315029  
400             $dot
401             $dot_s
402             $eD
403             $eS
404             $eW
405             $eH
406             $eV
407             $eR
408             $eN
409             $not_alnum
410             $not_alpha
411             $not_ascii
412             $not_blank
413             $not_cntrl
414             $not_digit
415             $not_graph
416             $not_lower
417             $not_lower_i
418             $not_print
419             $not_punct
420             $not_space
421             $not_upper
422             $not_upper_i
423             $not_word
424             $not_xdigit
425             $eb
426             $eB
427             ) } }
428              
429             ${Char::Elatin9::dot} = qr{(?:[^\x0A])};
430             ${Char::Elatin9::dot_s} = qr{(?:[\x00-\xFF])};
431             ${Char::Elatin9::eD} = qr{(?:[^0-9])};
432              
433             # Vertical tabs are now whitespace
434             # \s in a regex now matches a vertical tab in all circumstances.
435             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
436             # ${Char::Elatin9::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
437             # ${Char::Elatin9::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
438             ${Char::Elatin9::eS} = qr{(?:[^\s])};
439              
440             ${Char::Elatin9::eW} = qr{(?:[^0-9A-Z_a-z])};
441             ${Char::Elatin9::eH} = qr{(?:[^\x09\x20])};
442             ${Char::Elatin9::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
443             ${Char::Elatin9::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
444             ${Char::Elatin9::eN} = qr{(?:[^\x0A])};
445             ${Char::Elatin9::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
446             ${Char::Elatin9::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
447             ${Char::Elatin9::not_ascii} = qr{(?:[^\x00-\x7F])};
448             ${Char::Elatin9::not_blank} = qr{(?:[^\x09\x20])};
449             ${Char::Elatin9::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
450             ${Char::Elatin9::not_digit} = qr{(?:[^\x30-\x39])};
451             ${Char::Elatin9::not_graph} = qr{(?:[^\x21-\x7F])};
452             ${Char::Elatin9::not_lower} = qr{(?:[^\x61-\x7A])};
453             ${Char::Elatin9::not_lower_i} = qr{(?:[\x00-\xFF])};
454             ${Char::Elatin9::not_print} = qr{(?:[^\x20-\x7F])};
455             ${Char::Elatin9::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
456             ${Char::Elatin9::not_space} = qr{(?:[^\s\x0B])};
457             ${Char::Elatin9::not_upper} = qr{(?:[^\x41-\x5A])};
458             ${Char::Elatin9::not_upper_i} = qr{(?:[\x00-\xFF])};
459             ${Char::Elatin9::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
460             ${Char::Elatin9::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
461             ${Char::Elatin9::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))};
462             ${Char::Elatin9::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]))};
463              
464             # avoid: Name "Char::Elatin9::foo" used only once: possible typo at here.
465             ${Char::Elatin9::dot} = ${Char::Elatin9::dot};
466             ${Char::Elatin9::dot_s} = ${Char::Elatin9::dot_s};
467             ${Char::Elatin9::eD} = ${Char::Elatin9::eD};
468             ${Char::Elatin9::eS} = ${Char::Elatin9::eS};
469             ${Char::Elatin9::eW} = ${Char::Elatin9::eW};
470             ${Char::Elatin9::eH} = ${Char::Elatin9::eH};
471             ${Char::Elatin9::eV} = ${Char::Elatin9::eV};
472             ${Char::Elatin9::eR} = ${Char::Elatin9::eR};
473             ${Char::Elatin9::eN} = ${Char::Elatin9::eN};
474             ${Char::Elatin9::not_alnum} = ${Char::Elatin9::not_alnum};
475             ${Char::Elatin9::not_alpha} = ${Char::Elatin9::not_alpha};
476             ${Char::Elatin9::not_ascii} = ${Char::Elatin9::not_ascii};
477             ${Char::Elatin9::not_blank} = ${Char::Elatin9::not_blank};
478             ${Char::Elatin9::not_cntrl} = ${Char::Elatin9::not_cntrl};
479             ${Char::Elatin9::not_digit} = ${Char::Elatin9::not_digit};
480             ${Char::Elatin9::not_graph} = ${Char::Elatin9::not_graph};
481             ${Char::Elatin9::not_lower} = ${Char::Elatin9::not_lower};
482             ${Char::Elatin9::not_lower_i} = ${Char::Elatin9::not_lower_i};
483             ${Char::Elatin9::not_print} = ${Char::Elatin9::not_print};
484             ${Char::Elatin9::not_punct} = ${Char::Elatin9::not_punct};
485             ${Char::Elatin9::not_space} = ${Char::Elatin9::not_space};
486             ${Char::Elatin9::not_upper} = ${Char::Elatin9::not_upper};
487             ${Char::Elatin9::not_upper_i} = ${Char::Elatin9::not_upper_i};
488             ${Char::Elatin9::not_word} = ${Char::Elatin9::not_word};
489             ${Char::Elatin9::not_xdigit} = ${Char::Elatin9::not_xdigit};
490             ${Char::Elatin9::eb} = ${Char::Elatin9::eb};
491             ${Char::Elatin9::eB} = ${Char::Elatin9::eB};
492              
493             #
494             # Latin-9 split
495             #
496             sub Char::Elatin9::split(;$$$) {
497              
498             # P.794 29.2.161. split
499             # in Chapter 29: Functions
500             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
501              
502             # P.951 split
503             # in Chapter 27: Functions
504             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
505              
506 0     0 0 0 my $pattern = $_[0];
507 0         0 my $string = $_[1];
508 0         0 my $limit = $_[2];
509              
510             # if $pattern is also omitted or is the literal space, " "
511 0 0       0 if (not defined $pattern) {
512 0         0 $pattern = ' ';
513             }
514              
515             # if $string is omitted, the function splits the $_ string
516 0 0       0 if (not defined $string) {
517 0 0       0 if (defined $_) {
518 0         0 $string = $_;
519             }
520             else {
521 0         0 $string = '';
522             }
523             }
524              
525 0         0 my @split = ();
526              
527             # when string is empty
528 0 0       0 if ($string eq '') {
    0          
529              
530             # resulting list value in list context
531 0 0       0 if (wantarray) {
532 0         0 return @split;
533             }
534              
535             # count of substrings in scalar context
536             else {
537 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
538 0         0 @_ = @split;
539 0         0 return scalar @_;
540             }
541             }
542              
543             # split's first argument is more consistently interpreted
544             #
545             # After some changes earlier in v5.17, split's behavior has been simplified:
546             # if the PATTERN argument evaluates to a string containing one space, it is
547             # treated the way that a literal string containing one space once was.
548             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
549              
550             # if $pattern is also omitted or is the literal space, " ", the function splits
551             # on whitespace, /\s+/, after skipping any leading whitespace
552             # (and so on)
553              
554             elsif ($pattern eq ' ') {
555 0 0       0 if (not defined $limit) {
556 0         0 return CORE::split(' ', $string);
557             }
558             else {
559 0         0 return CORE::split(' ', $string, $limit);
560             }
561             }
562              
563             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
564 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
565              
566             # a pattern capable of matching either the null string or something longer than the
567             # null string will split the value of $string into separate characters wherever it
568             # matches the null string between characters
569             # (and so on)
570              
571 0 0       0 if ('' =~ / \A $pattern \z /xms) {
572 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
573 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
574              
575             # P.1024 Appendix W.10 Multibyte Processing
576             # of ISBN 1-56592-224-7 CJKV Information Processing
577             # (and so on)
578              
579             # the //m modifier is assumed when you split on the pattern /^/
580             # (and so on)
581              
582             # V
583 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
584              
585             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
586             # is included in the resulting list, interspersed with the fields that are ordinarily returned
587             # (and so on)
588              
589 0         0 local $@;
590 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
591 0         0 push @split, CORE::eval('$' . $digit);
592             }
593             }
594             }
595              
596             else {
597 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
598              
599             # V
600 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
601 0         0 local $@;
602 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
603 0         0 push @split, CORE::eval('$' . $digit);
604             }
605             }
606             }
607             }
608              
609             elsif ($limit > 0) {
610 0 0       0 if ('' =~ / \A $pattern \z /xms) {
611 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
612 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
613              
614             # V
615 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
616 0         0 local $@;
617 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
618 0         0 push @split, CORE::eval('$' . $digit);
619             }
620             }
621             }
622             }
623             else {
624 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
625 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
626              
627             # V
628 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
629 0         0 local $@;
630 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
631 0         0 push @split, CORE::eval('$' . $digit);
632             }
633             }
634             }
635             }
636             }
637              
638 0 0       0 if (CORE::length($string) > 0) {
639 0         0 push @split, $string;
640             }
641              
642             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
643 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
644 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
645 0         0 pop @split;
646             }
647             }
648              
649             # resulting list value in list context
650 0 0       0 if (wantarray) {
651 0         0 return @split;
652             }
653              
654             # count of substrings in scalar context
655             else {
656 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
657 0         0 @_ = @split;
658 0         0 return scalar @_;
659             }
660             }
661              
662             #
663             # get last subexpression offsets
664             #
665             sub _last_subexpression_offsets {
666 0     0   0 my $pattern = $_[0];
667              
668             # remove comment
669 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
670              
671 0         0 my $modifier = '';
672 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
673 0         0 $modifier = $1;
674 0         0 $modifier =~ s/-[A-Za-z]*//;
675             }
676              
677             # with /x modifier
678 0         0 my @char = ();
679 0 0       0 if ($modifier =~ /x/oxms) {
680 0         0 @char = $pattern =~ /\G(
681             \\ (?:$q_char) |
682             \# (?:$q_char)*? $ |
683             \[ (?: \\\] | (?:$q_char))+? \] |
684             \(\? |
685             (?:$q_char)
686             )/oxmsg;
687             }
688              
689             # without /x modifier
690             else {
691 0         0 @char = $pattern =~ /\G(
692             \\ (?:$q_char) |
693             \[ (?: \\\] | (?:$q_char))+? \] |
694             \(\? |
695             (?:$q_char)
696             )/oxmsg;
697             }
698              
699 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
700             }
701              
702             #
703             # Latin-9 transliteration (tr///)
704             #
705             sub Char::Elatin9::tr($$$$;$) {
706              
707 0     0 0 0 my $bind_operator = $_[1];
708 0         0 my $searchlist = $_[2];
709 0         0 my $replacementlist = $_[3];
710 0   0     0 my $modifier = $_[4] || '';
711              
712 0 0       0 if ($modifier =~ /r/oxms) {
713 0 0       0 if ($bind_operator =~ / !~ /oxms) {
714 0         0 croak "Using !~ with tr///r doesn't make sense";
715             }
716             }
717              
718 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
719 0         0 my @searchlist = _charlist_tr($searchlist);
720 0         0 my @replacementlist = _charlist_tr($replacementlist);
721              
722 0         0 my %tr = ();
723 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
724 0 0       0 if (not exists $tr{$searchlist[$i]}) {
725 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
726 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
727             }
728             elsif ($modifier =~ /d/oxms) {
729 0         0 $tr{$searchlist[$i]} = '';
730             }
731             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
732 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
733             }
734             else {
735 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
736             }
737             }
738             }
739              
740 0         0 my $tr = 0;
741 0         0 my $replaced = '';
742 0 0       0 if ($modifier =~ /c/oxms) {
743 0         0 while (defined(my $char = shift @char)) {
744 0 0       0 if (not exists $tr{$char}) {
745 0 0       0 if (defined $replacementlist[0]) {
746 0         0 $replaced .= $replacementlist[0];
747             }
748 0         0 $tr++;
749 0 0       0 if ($modifier =~ /s/oxms) {
750 0   0     0 while (@char and (not exists $tr{$char[0]})) {
751 0         0 shift @char;
752 0         0 $tr++;
753             }
754             }
755             }
756             else {
757 0         0 $replaced .= $char;
758             }
759             }
760             }
761             else {
762 0         0 while (defined(my $char = shift @char)) {
763 0 0       0 if (exists $tr{$char}) {
764 0         0 $replaced .= $tr{$char};
765 0         0 $tr++;
766 0 0       0 if ($modifier =~ /s/oxms) {
767 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
768 0         0 shift @char;
769 0         0 $tr++;
770             }
771             }
772             }
773             else {
774 0         0 $replaced .= $char;
775             }
776             }
777             }
778              
779 0 0       0 if ($modifier =~ /r/oxms) {
780 0         0 return $replaced;
781             }
782             else {
783 0         0 $_[0] = $replaced;
784 0 0       0 if ($bind_operator =~ / !~ /oxms) {
785 0         0 return not $tr;
786             }
787             else {
788 0         0 return $tr;
789             }
790             }
791             }
792              
793             #
794             # Latin-9 chop
795             #
796             sub Char::Elatin9::chop(@) {
797              
798 0     0 0 0 my $chop;
799 0 0       0 if (@_ == 0) {
800 0         0 my @char = /\G ($q_char) /oxmsg;
801 0         0 $chop = pop @char;
802 0         0 $_ = join '', @char;
803             }
804             else {
805 0         0 for (@_) {
806 0         0 my @char = /\G ($q_char) /oxmsg;
807 0         0 $chop = pop @char;
808 0         0 $_ = join '', @char;
809             }
810             }
811 0         0 return $chop;
812             }
813              
814             #
815             # Latin-9 index by octet
816             #
817             sub Char::Elatin9::index($$;$) {
818              
819 0     0 1 0 my($str,$substr,$position) = @_;
820 0   0     0 $position ||= 0;
821 0         0 my $pos = 0;
822              
823 0         0 while ($pos < CORE::length($str)) {
824 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
825 0 0       0 if ($pos >= $position) {
826 0         0 return $pos;
827             }
828             }
829 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
830 0         0 $pos += CORE::length($1);
831             }
832             else {
833 0         0 $pos += 1;
834             }
835             }
836 0         0 return -1;
837             }
838              
839             #
840             # Latin-9 reverse index
841             #
842             sub Char::Elatin9::rindex($$;$) {
843              
844 0     0 0 0 my($str,$substr,$position) = @_;
845 0   0     0 $position ||= CORE::length($str) - 1;
846 0         0 my $pos = 0;
847 0         0 my $rindex = -1;
848              
849 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
850 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
851 0         0 $rindex = $pos;
852             }
853 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
854 0         0 $pos += CORE::length($1);
855             }
856             else {
857 0         0 $pos += 1;
858             }
859             }
860 0         0 return $rindex;
861             }
862              
863             #
864             # Latin-9 lower case first with parameter
865             #
866             sub Char::Elatin9::lcfirst(@) {
867 0 0   0 0 0 if (@_) {
868 0         0 my $s = shift @_;
869 0 0 0     0 if (@_ and wantarray) {
870 0         0 return Char::Elatin9::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
871             }
872             else {
873 0         0 return Char::Elatin9::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
874             }
875             }
876             else {
877 0         0 return Char::Elatin9::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
878             }
879             }
880              
881             #
882             # Latin-9 lower case first without parameter
883             #
884             sub Char::Elatin9::lcfirst_() {
885 0     0 0 0 return Char::Elatin9::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
886             }
887              
888             #
889             # Latin-9 lower case with parameter
890             #
891             sub Char::Elatin9::lc(@) {
892 0 0   0 0 0 if (@_) {
893 0         0 my $s = shift @_;
894 0 0 0     0 if (@_ and wantarray) {
895 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
896             }
897             else {
898 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
899             }
900             }
901             else {
902 0         0 return Char::Elatin9::lc_();
903             }
904             }
905              
906             #
907             # Latin-9 lower case without parameter
908             #
909             sub Char::Elatin9::lc_() {
910 0     0 0 0 my $s = $_;
911 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
912             }
913              
914             #
915             # Latin-9 upper case first with parameter
916             #
917             sub Char::Elatin9::ucfirst(@) {
918 0 0   0 0 0 if (@_) {
919 0         0 my $s = shift @_;
920 0 0 0     0 if (@_ and wantarray) {
921 0         0 return Char::Elatin9::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
922             }
923             else {
924 0         0 return Char::Elatin9::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
925             }
926             }
927             else {
928 0         0 return Char::Elatin9::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
929             }
930             }
931              
932             #
933             # Latin-9 upper case first without parameter
934             #
935             sub Char::Elatin9::ucfirst_() {
936 0     0 0 0 return Char::Elatin9::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
937             }
938              
939             #
940             # Latin-9 upper case with parameter
941             #
942             sub Char::Elatin9::uc(@) {
943 0 0   0 0 0 if (@_) {
944 0         0 my $s = shift @_;
945 0 0 0     0 if (@_ and wantarray) {
946 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
947             }
948             else {
949 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
950             }
951             }
952             else {
953 0         0 return Char::Elatin9::uc_();
954             }
955             }
956              
957             #
958             # Latin-9 upper case without parameter
959             #
960             sub Char::Elatin9::uc_() {
961 0     0 0 0 my $s = $_;
962 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
963             }
964              
965             #
966             # Latin-9 fold case with parameter
967             #
968             sub Char::Elatin9::fc(@) {
969 0 0   0 0 0 if (@_) {
970 0         0 my $s = shift @_;
971 0 0 0     0 if (@_ and wantarray) {
972 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
973             }
974             else {
975 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
976             }
977             }
978             else {
979 0         0 return Char::Elatin9::fc_();
980             }
981             }
982              
983             #
984             # Latin-9 fold case without parameter
985             #
986             sub Char::Elatin9::fc_() {
987 0     0 0 0 my $s = $_;
988 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
989             }
990              
991             #
992             # Latin-9 regexp capture
993             #
994             {
995             sub Char::Elatin9::capture {
996 0     0 1 0 return $_[0];
997             }
998             }
999              
1000             #
1001             # Latin-9 regexp ignore case modifier
1002             #
1003             sub Char::Elatin9::ignorecase {
1004              
1005 0     0 0 0 my @string = @_;
1006 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1007              
1008             # ignore case of $scalar or @array
1009 0         0 for my $string (@string) {
1010              
1011             # split regexp
1012 0         0 my @char = $string =~ /\G(
1013             \[\^ |
1014             \\? (?:$q_char)
1015             )/oxmsg;
1016              
1017             # unescape character
1018 0         0 for (my $i=0; $i <= $#char; $i++) {
1019 0 0       0 next if not defined $char[$i];
1020              
1021             # open character class [...]
1022 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1023 0         0 my $left = $i;
1024              
1025             # [] make die "unmatched [] in regexp ..."
1026              
1027 0 0       0 if ($char[$i+1] eq ']') {
1028 0         0 $i++;
1029             }
1030              
1031 0         0 while (1) {
1032 0 0       0 if (++$i > $#char) {
1033 0         0 croak "Unmatched [] in regexp";
1034             }
1035 0 0       0 if ($char[$i] eq ']') {
1036 0         0 my $right = $i;
1037 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1038              
1039             # escape character
1040 0         0 for my $char (@charlist) {
1041 0 0       0 if (0) {
1042             }
1043              
1044 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1045 0         0 $char = $1 . '\\' . $char;
1046             }
1047             }
1048              
1049             # [...]
1050 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1051              
1052 0         0 $i = $left;
1053 0         0 last;
1054             }
1055             }
1056             }
1057              
1058             # open character class [^...]
1059             elsif ($char[$i] eq '[^') {
1060 0         0 my $left = $i;
1061              
1062             # [^] make die "unmatched [] in regexp ..."
1063              
1064 0 0       0 if ($char[$i+1] eq ']') {
1065 0         0 $i++;
1066             }
1067              
1068 0         0 while (1) {
1069 0 0       0 if (++$i > $#char) {
1070 0         0 croak "Unmatched [] in regexp";
1071             }
1072 0 0       0 if ($char[$i] eq ']') {
1073 0         0 my $right = $i;
1074 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1075              
1076             # escape character
1077 0         0 for my $char (@charlist) {
1078 0 0       0 if (0) {
1079             }
1080              
1081 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1082 0         0 $char = '\\' . $char;
1083             }
1084             }
1085              
1086             # [^...]
1087 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1088              
1089 0         0 $i = $left;
1090 0         0 last;
1091             }
1092             }
1093             }
1094              
1095             # rewrite classic character class or escape character
1096             elsif (my $char = classic_character_class($char[$i])) {
1097 0         0 $char[$i] = $char;
1098             }
1099              
1100             # with /i modifier
1101             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1102 0         0 my $uc = Char::Elatin9::uc($char[$i]);
1103 0         0 my $fc = Char::Elatin9::fc($char[$i]);
1104 0 0       0 if ($uc ne $fc) {
1105 0 0       0 if (CORE::length($fc) == 1) {
1106 0         0 $char[$i] = '[' . $uc . $fc . ']';
1107             }
1108             else {
1109 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1110             }
1111             }
1112             }
1113             }
1114              
1115             # characterize
1116 0         0 for (my $i=0; $i <= $#char; $i++) {
1117 0 0       0 next if not defined $char[$i];
1118              
1119 0 0       0 if (0) {
1120             }
1121              
1122             # quote character before ? + * {
1123 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1124 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1125 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1126             }
1127             }
1128             }
1129              
1130 0         0 $string = join '', @char;
1131             }
1132              
1133             # make regexp string
1134 0         0 return @string;
1135             }
1136              
1137             #
1138             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1139             #
1140             sub Char::Elatin9::classic_character_class {
1141 0     0 0 0 my($char) = @_;
1142              
1143             return {
1144 0   0     0 '\D' => '${Char::Elatin9::eD}',
1145             '\S' => '${Char::Elatin9::eS}',
1146             '\W' => '${Char::Elatin9::eW}',
1147             '\d' => '[0-9]',
1148              
1149             # Before Perl 5.6, \s only matched the five whitespace characters
1150             # tab, newline, form-feed, carriage return, and the space character
1151             # itself, which, taken together, is the character class [\t\n\f\r ].
1152              
1153             # Vertical tabs are now whitespace
1154             # \s in a regex now matches a vertical tab in all circumstances.
1155             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1156             # \t \n \v \f \r space
1157             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1158             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1159             '\s' => '\s',
1160              
1161             '\w' => '[0-9A-Z_a-z]',
1162             '\C' => '[\x00-\xFF]',
1163             '\X' => 'X',
1164              
1165             # \h \v \H \V
1166              
1167             # P.114 Character Class Shortcuts
1168             # in Chapter 7: In the World of Regular Expressions
1169             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1170              
1171             # P.357 13.2.3 Whitespace
1172             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1173             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1174             #
1175             # 0x00009 CHARACTER TABULATION h s
1176             # 0x0000a LINE FEED (LF) vs
1177             # 0x0000b LINE TABULATION v
1178             # 0x0000c FORM FEED (FF) vs
1179             # 0x0000d CARRIAGE RETURN (CR) vs
1180             # 0x00020 SPACE h s
1181              
1182             # P.196 Table 5-9. Alphanumeric regex metasymbols
1183             # in Chapter 5. Pattern Matching
1184             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1185              
1186             # (and so on)
1187              
1188             '\H' => '${Char::Elatin9::eH}',
1189             '\V' => '${Char::Elatin9::eV}',
1190             '\h' => '[\x09\x20]',
1191             '\v' => '[\x0A\x0B\x0C\x0D]',
1192             '\R' => '${Char::Elatin9::eR}',
1193              
1194             # \N
1195             #
1196             # http://perldoc.perl.org/perlre.html
1197             # Character Classes and other Special Escapes
1198             # Any character but \n (experimental). Not affected by /s modifier
1199              
1200             '\N' => '${Char::Elatin9::eN}',
1201              
1202             # \b \B
1203              
1204             # P.180 Boundaries: The \b and \B Assertions
1205             # in Chapter 5: Pattern Matching
1206             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1207              
1208             # P.219 Boundaries: The \b and \B Assertions
1209             # in Chapter 5: Pattern Matching
1210             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1211              
1212             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1213             '\b' => '${Char::Elatin9::eb}',
1214              
1215             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1216             '\B' => '${Char::Elatin9::eB}',
1217              
1218             }->{$char} || '';
1219             }
1220              
1221             #
1222             # prepare Latin-9 characters per length
1223             #
1224              
1225             # 1 octet characters
1226             my @chars1 = ();
1227             sub chars1 {
1228 0 0   0 0 0 if (@chars1) {
1229 0         0 return @chars1;
1230             }
1231 0 0       0 if (exists $range_tr{1}) {
1232 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1233 0         0 while (my @range = splice(@ranges,0,1)) {
1234 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1235 0         0 push @chars1, pack 'C', $oct0;
1236             }
1237             }
1238             }
1239 0         0 return @chars1;
1240             }
1241              
1242             # 2 octets characters
1243             my @chars2 = ();
1244             sub chars2 {
1245 0 0   0 0 0 if (@chars2) {
1246 0         0 return @chars2;
1247             }
1248 0 0       0 if (exists $range_tr{2}) {
1249 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1250 0         0 while (my @range = splice(@ranges,0,2)) {
1251 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1252 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1253 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1254             }
1255             }
1256             }
1257             }
1258 0         0 return @chars2;
1259             }
1260              
1261             # 3 octets characters
1262             my @chars3 = ();
1263             sub chars3 {
1264 0 0   0 0 0 if (@chars3) {
1265 0         0 return @chars3;
1266             }
1267 0 0       0 if (exists $range_tr{3}) {
1268 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1269 0         0 while (my @range = splice(@ranges,0,3)) {
1270 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1271 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1272 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1273 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1274             }
1275             }
1276             }
1277             }
1278             }
1279 0         0 return @chars3;
1280             }
1281              
1282             # 4 octets characters
1283             my @chars4 = ();
1284             sub chars4 {
1285 0 0   0 0 0 if (@chars4) {
1286 0         0 return @chars4;
1287             }
1288 0 0       0 if (exists $range_tr{4}) {
1289 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1290 0         0 while (my @range = splice(@ranges,0,4)) {
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 for my $oct3 (@{$range[3]}) {
  0         0  
1295 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1296             }
1297             }
1298             }
1299             }
1300             }
1301             }
1302 0         0 return @chars4;
1303             }
1304              
1305             #
1306             # Latin-9 open character list for tr
1307             #
1308             sub _charlist_tr {
1309              
1310 0     0   0 local $_ = shift @_;
1311              
1312             # unescape character
1313 0         0 my @char = ();
1314 0         0 while (not /\G \z/oxmsgc) {
1315 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1316 0         0 push @char, '\-';
1317             }
1318             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1319 0         0 push @char, CORE::chr(oct $1);
1320             }
1321             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1322 0         0 push @char, CORE::chr(hex $1);
1323             }
1324             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1325 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1326             }
1327             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1328 0         0 push @char, {
1329             '\0' => "\0",
1330             '\n' => "\n",
1331             '\r' => "\r",
1332             '\t' => "\t",
1333             '\f' => "\f",
1334             '\b' => "\x08", # \b means backspace in character class
1335             '\a' => "\a",
1336             '\e' => "\e",
1337             }->{$1};
1338             }
1339             elsif (/\G \\ ($q_char) /oxmsgc) {
1340 0         0 push @char, $1;
1341             }
1342             elsif (/\G ($q_char) /oxmsgc) {
1343 0         0 push @char, $1;
1344             }
1345             }
1346              
1347             # join separated multiple-octet
1348 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1349              
1350             # unescape '-'
1351 0         0 my @i = ();
1352 0         0 for my $i (0 .. $#char) {
1353 0 0       0 if ($char[$i] eq '\-') {
    0          
1354 0         0 $char[$i] = '-';
1355             }
1356             elsif ($char[$i] eq '-') {
1357 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1358 0         0 push @i, $i;
1359             }
1360             }
1361             }
1362              
1363             # open character list (reverse for splice)
1364 0         0 for my $i (CORE::reverse @i) {
1365 0         0 my @range = ();
1366              
1367             # range error
1368 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1369 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1370             }
1371              
1372             # range of multiple-octet code
1373 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1374 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1375 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1376             }
1377             elsif (CORE::length($char[$i+1]) == 2) {
1378 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1379 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1380             }
1381             elsif (CORE::length($char[$i+1]) == 3) {
1382 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1383 0         0 push @range, chars2();
1384 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1385             }
1386             elsif (CORE::length($char[$i+1]) == 4) {
1387 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1388 0         0 push @range, chars2();
1389 0         0 push @range, chars3();
1390 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1391             }
1392             else {
1393 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1394             }
1395             }
1396             elsif (CORE::length($char[$i-1]) == 2) {
1397 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1398 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1399             }
1400             elsif (CORE::length($char[$i+1]) == 3) {
1401 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1402 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1403             }
1404             elsif (CORE::length($char[$i+1]) == 4) {
1405 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1406 0         0 push @range, chars3();
1407 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1408             }
1409             else {
1410 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1411             }
1412             }
1413             elsif (CORE::length($char[$i-1]) == 3) {
1414 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1415 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1416             }
1417             elsif (CORE::length($char[$i+1]) == 4) {
1418 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1419 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1420             }
1421             else {
1422 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1423             }
1424             }
1425             elsif (CORE::length($char[$i-1]) == 4) {
1426 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1427 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1428             }
1429             else {
1430 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1431             }
1432             }
1433             else {
1434 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1435             }
1436              
1437 0         0 splice @char, $i-1, 3, @range;
1438             }
1439              
1440 0         0 return @char;
1441             }
1442              
1443             #
1444             # Latin-9 open character class
1445             #
1446             sub _cc {
1447 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1448 0         0 die __FILE__, ": subroutine cc got no parameter.";
1449             }
1450             elsif (scalar(@_) == 1) {
1451 0         0 return sprintf('\x%02X',$_[0]);
1452             }
1453             elsif (scalar(@_) == 2) {
1454 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1455 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1456             }
1457             elsif ($_[0] == $_[1]) {
1458 0         0 return sprintf('\x%02X',$_[0]);
1459             }
1460             elsif (($_[0]+1) == $_[1]) {
1461 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1462             }
1463             else {
1464 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1465             }
1466             }
1467             else {
1468 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1469             }
1470             }
1471              
1472             #
1473             # Latin-9 octet range
1474             #
1475             sub _octets {
1476 0     0   0 my $length = shift @_;
1477              
1478 0 0       0 if ($length == 1) {
1479 0         0 my($a1) = unpack 'C', $_[0];
1480 0         0 my($z1) = unpack 'C', $_[1];
1481              
1482 0 0       0 if ($a1 > $z1) {
1483 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1484             }
1485              
1486 0 0       0 if ($a1 == $z1) {
    0          
1487 0         0 return sprintf('\x%02X',$a1);
1488             }
1489             elsif (($a1+1) == $z1) {
1490 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1491             }
1492             else {
1493 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1494             }
1495             }
1496             else {
1497 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1498             }
1499             }
1500              
1501             #
1502             # Latin-9 range regexp
1503             #
1504             sub _range_regexp {
1505 0     0   0 my($length,$first,$last) = @_;
1506              
1507 0         0 my @range_regexp = ();
1508 0 0       0 if (not exists $range_tr{$length}) {
1509 0         0 return @range_regexp;
1510             }
1511              
1512 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1513 0         0 while (my @range = splice(@ranges,0,$length)) {
1514 0         0 my $min = '';
1515 0         0 my $max = '';
1516 0         0 for (my $i=0; $i < $length; $i++) {
1517 0         0 $min .= pack 'C', $range[$i][0];
1518 0         0 $max .= pack 'C', $range[$i][-1];
1519             }
1520              
1521             # min___max
1522             # FIRST_____________LAST
1523             # (nothing)
1524              
1525 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1526             }
1527              
1528             # **********
1529             # min_________max
1530             # FIRST_____________LAST
1531             # **********
1532              
1533             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1534 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1535             }
1536              
1537             # **********************
1538             # min________________max
1539             # FIRST_____________LAST
1540             # **********************
1541              
1542             elsif (($min eq $first) and ($max eq $last)) {
1543 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1544             }
1545              
1546             # *********
1547             # min___max
1548             # FIRST_____________LAST
1549             # *********
1550              
1551             elsif (($first le $min) and ($max le $last)) {
1552 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1553             }
1554              
1555             # **********************
1556             # min__________________________max
1557             # FIRST_____________LAST
1558             # **********************
1559              
1560             elsif (($min le $first) and ($last le $max)) {
1561 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1562             }
1563              
1564             # *********
1565             # min________max
1566             # FIRST_____________LAST
1567             # *********
1568              
1569             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1570 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1571             }
1572              
1573             # min___max
1574             # FIRST_____________LAST
1575             # (nothing)
1576              
1577             elsif ($last lt $min) {
1578             }
1579              
1580             else {
1581 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1582             }
1583             }
1584              
1585 0         0 return @range_regexp;
1586             }
1587              
1588             #
1589             # Latin-9 open character list for qr and not qr
1590             #
1591             sub _charlist {
1592              
1593 0     0   0 my $modifier = pop @_;
1594 0         0 my @char = @_;
1595              
1596 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1597              
1598             # unescape character
1599 0         0 for (my $i=0; $i <= $#char; $i++) {
1600              
1601             # escape - to ...
1602 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1603 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1604 0         0 $char[$i] = '...';
1605             }
1606             }
1607              
1608             # octal escape sequence
1609             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1610 0         0 $char[$i] = octchr($1);
1611             }
1612              
1613             # hexadecimal escape sequence
1614             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1615 0         0 $char[$i] = hexchr($1);
1616             }
1617              
1618             # \N{CHARNAME} --> N\{CHARNAME}
1619             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1620 0         0 $char[$i] = $1 . '\\' . $2;
1621             }
1622              
1623             # \p{PROPERTY} --> p\{PROPERTY}
1624             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1625 0         0 $char[$i] = $1 . '\\' . $2;
1626             }
1627              
1628             # \P{PROPERTY} --> P\{PROPERTY}
1629             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1630 0         0 $char[$i] = $1 . '\\' . $2;
1631             }
1632              
1633             # \p, \P, \X --> p, P, X
1634             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1635 0         0 $char[$i] = $1;
1636             }
1637              
1638             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1639 0         0 $char[$i] = CORE::chr oct $1;
1640             }
1641             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1642 0         0 $char[$i] = CORE::chr hex $1;
1643             }
1644             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1645 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1646             }
1647             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1648 0         0 $char[$i] = {
1649             '\0' => "\0",
1650             '\n' => "\n",
1651             '\r' => "\r",
1652             '\t' => "\t",
1653             '\f' => "\f",
1654             '\b' => "\x08", # \b means backspace in character class
1655             '\a' => "\a",
1656             '\e' => "\e",
1657             '\d' => '[0-9]',
1658              
1659             # Vertical tabs are now whitespace
1660             # \s in a regex now matches a vertical tab in all circumstances.
1661             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1662             # \t \n \v \f \r space
1663             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1664             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1665             '\s' => '\s',
1666              
1667             '\w' => '[0-9A-Z_a-z]',
1668             '\D' => '${Char::Elatin9::eD}',
1669             '\S' => '${Char::Elatin9::eS}',
1670             '\W' => '${Char::Elatin9::eW}',
1671              
1672             '\H' => '${Char::Elatin9::eH}',
1673             '\V' => '${Char::Elatin9::eV}',
1674             '\h' => '[\x09\x20]',
1675             '\v' => '[\x0A\x0B\x0C\x0D]',
1676             '\R' => '${Char::Elatin9::eR}',
1677              
1678             }->{$1};
1679             }
1680              
1681             # POSIX-style character classes
1682             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1683 0         0 $char[$i] = {
1684              
1685             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1686             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1687             '[:^lower:]' => '${Char::Elatin9::not_lower_i}',
1688             '[:^upper:]' => '${Char::Elatin9::not_upper_i}',
1689              
1690             }->{$1};
1691             }
1692             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1693 0         0 $char[$i] = {
1694              
1695             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1696             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1697             '[:ascii:]' => '[\x00-\x7F]',
1698             '[:blank:]' => '[\x09\x20]',
1699             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1700             '[:digit:]' => '[\x30-\x39]',
1701             '[:graph:]' => '[\x21-\x7F]',
1702             '[:lower:]' => '[\x61-\x7A]',
1703             '[:print:]' => '[\x20-\x7F]',
1704             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1705              
1706             # P.174 POSIX-Style Character Classes
1707             # in Chapter 5: Pattern Matching
1708             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1709              
1710             # P.311 11.2.4 Character Classes and other Special Escapes
1711             # in Chapter 11: perlre: Perl regular expressions
1712             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1713              
1714             # P.210 POSIX-Style Character Classes
1715             # in Chapter 5: Pattern Matching
1716             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1717              
1718             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1719              
1720             '[:upper:]' => '[\x41-\x5A]',
1721             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1722             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1723             '[:^alnum:]' => '${Char::Elatin9::not_alnum}',
1724             '[:^alpha:]' => '${Char::Elatin9::not_alpha}',
1725             '[:^ascii:]' => '${Char::Elatin9::not_ascii}',
1726             '[:^blank:]' => '${Char::Elatin9::not_blank}',
1727             '[:^cntrl:]' => '${Char::Elatin9::not_cntrl}',
1728             '[:^digit:]' => '${Char::Elatin9::not_digit}',
1729             '[:^graph:]' => '${Char::Elatin9::not_graph}',
1730             '[:^lower:]' => '${Char::Elatin9::not_lower}',
1731             '[:^print:]' => '${Char::Elatin9::not_print}',
1732             '[:^punct:]' => '${Char::Elatin9::not_punct}',
1733             '[:^space:]' => '${Char::Elatin9::not_space}',
1734             '[:^upper:]' => '${Char::Elatin9::not_upper}',
1735             '[:^word:]' => '${Char::Elatin9::not_word}',
1736             '[:^xdigit:]' => '${Char::Elatin9::not_xdigit}',
1737              
1738             }->{$1};
1739             }
1740             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1741 0         0 $char[$i] = $1;
1742             }
1743             }
1744              
1745             # open character list
1746 0         0 my @singleoctet = ();
1747 0         0 my @multipleoctet = ();
1748 0         0 for (my $i=0; $i <= $#char; ) {
1749              
1750             # escaped -
1751 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1752 0         0 $i += 1;
1753 0         0 next;
1754             }
1755              
1756             # make range regexp
1757             elsif ($char[$i] eq '...') {
1758              
1759             # range error
1760 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1761 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1762             }
1763             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1764 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1765 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]);
1766             }
1767             }
1768              
1769             # make range regexp per length
1770 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1771 0         0 my @regexp = ();
1772              
1773             # is first and last
1774 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1775 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1776             }
1777              
1778             # is first
1779             elsif ($length == CORE::length($char[$i-1])) {
1780 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1781             }
1782              
1783             # is inside in first and last
1784             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1785 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1786             }
1787              
1788             # is last
1789             elsif ($length == CORE::length($char[$i+1])) {
1790 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1791             }
1792              
1793             else {
1794 0         0 die __FILE__, ": subroutine make_regexp panic.";
1795             }
1796              
1797 0 0       0 if ($length == 1) {
1798 0         0 push @singleoctet, @regexp;
1799             }
1800             else {
1801 0         0 push @multipleoctet, @regexp;
1802             }
1803             }
1804              
1805 0         0 $i += 2;
1806             }
1807              
1808             # with /i modifier
1809             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1810 0 0       0 if ($modifier =~ /i/oxms) {
1811 0         0 my $uc = Char::Elatin9::uc($char[$i]);
1812 0         0 my $fc = Char::Elatin9::fc($char[$i]);
1813 0 0       0 if ($uc ne $fc) {
1814 0 0       0 if (CORE::length($fc) == 1) {
1815 0         0 push @singleoctet, $uc, $fc;
1816             }
1817             else {
1818 0         0 push @singleoctet, $uc;
1819 0         0 push @multipleoctet, $fc;
1820             }
1821             }
1822             else {
1823 0         0 push @singleoctet, $char[$i];
1824             }
1825             }
1826             else {
1827 0         0 push @singleoctet, $char[$i];
1828             }
1829 0         0 $i += 1;
1830             }
1831              
1832             # single character of single octet code
1833             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1834 0         0 push @singleoctet, "\t", "\x20";
1835 0         0 $i += 1;
1836             }
1837             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1838 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1839 0         0 $i += 1;
1840             }
1841             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1842 0         0 push @singleoctet, $char[$i];
1843 0         0 $i += 1;
1844             }
1845              
1846             # single character of multiple-octet code
1847             else {
1848 0         0 push @multipleoctet, $char[$i];
1849 0         0 $i += 1;
1850             }
1851             }
1852              
1853             # quote metachar
1854 0         0 for (@singleoctet) {
1855 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1856 0         0 $_ = '-';
1857             }
1858             elsif (/\A \n \z/oxms) {
1859 0         0 $_ = '\n';
1860             }
1861             elsif (/\A \r \z/oxms) {
1862 0         0 $_ = '\r';
1863             }
1864             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1865 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1866             }
1867             elsif (/\A [\x00-\xFF] \z/oxms) {
1868 0         0 $_ = quotemeta $_;
1869             }
1870             }
1871              
1872             # return character list
1873 0         0 return \@singleoctet, \@multipleoctet;
1874             }
1875              
1876             #
1877             # Latin-9 octal escape sequence
1878             #
1879             sub octchr {
1880 0     0 0 0 my($octdigit) = @_;
1881              
1882 0         0 my @binary = ();
1883 0         0 for my $octal (split(//,$octdigit)) {
1884 0         0 push @binary, {
1885             '0' => '000',
1886             '1' => '001',
1887             '2' => '010',
1888             '3' => '011',
1889             '4' => '100',
1890             '5' => '101',
1891             '6' => '110',
1892             '7' => '111',
1893             }->{$octal};
1894             }
1895 0         0 my $binary = join '', @binary;
1896              
1897 0         0 my $octchr = {
1898             # 1234567
1899             1 => pack('B*', "0000000$binary"),
1900             2 => pack('B*', "000000$binary"),
1901             3 => pack('B*', "00000$binary"),
1902             4 => pack('B*', "0000$binary"),
1903             5 => pack('B*', "000$binary"),
1904             6 => pack('B*', "00$binary"),
1905             7 => pack('B*', "0$binary"),
1906             0 => pack('B*', "$binary"),
1907              
1908             }->{CORE::length($binary) % 8};
1909              
1910 0         0 return $octchr;
1911             }
1912              
1913             #
1914             # Latin-9 hexadecimal escape sequence
1915             #
1916             sub hexchr {
1917 0     0 0 0 my($hexdigit) = @_;
1918              
1919 0         0 my $hexchr = {
1920             1 => pack('H*', "0$hexdigit"),
1921             0 => pack('H*', "$hexdigit"),
1922              
1923             }->{CORE::length($_[0]) % 2};
1924              
1925 0         0 return $hexchr;
1926             }
1927              
1928             #
1929             # Latin-9 open character list for qr
1930             #
1931             sub charlist_qr {
1932              
1933 0     0 0 0 my $modifier = pop @_;
1934 0         0 my @char = @_;
1935              
1936 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1937 0         0 my @singleoctet = @$singleoctet;
1938 0         0 my @multipleoctet = @$multipleoctet;
1939              
1940             # return character list
1941 0 0       0 if (scalar(@singleoctet) >= 1) {
1942              
1943             # with /i modifier
1944 0 0       0 if ($modifier =~ m/i/oxms) {
1945 0         0 my %singleoctet_ignorecase = ();
1946 0         0 for (@singleoctet) {
1947 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1948 0         0 for my $ord (hex($1) .. hex($2)) {
1949 0         0 my $char = CORE::chr($ord);
1950 0         0 my $uc = Char::Elatin9::uc($char);
1951 0         0 my $fc = Char::Elatin9::fc($char);
1952 0 0       0 if ($uc eq $fc) {
1953 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1954             }
1955             else {
1956 0 0       0 if (CORE::length($fc) == 1) {
1957 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1958 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1959             }
1960             else {
1961 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1962 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1963             }
1964             }
1965             }
1966             }
1967 0 0       0 if ($_ ne '') {
1968 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1969             }
1970             }
1971 0         0 my $i = 0;
1972 0         0 my @singleoctet_ignorecase = ();
1973 0         0 for my $ord (0 .. 255) {
1974 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1975 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1976             }
1977             else {
1978 0         0 $i++;
1979             }
1980             }
1981 0         0 @singleoctet = ();
1982 0         0 for my $range (@singleoctet_ignorecase) {
1983 0 0       0 if (ref $range) {
1984 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1985 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1986             }
1987             elsif (scalar(@{$range}) == 2) {
1988 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1989             }
1990             else {
1991 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1992             }
1993             }
1994             }
1995             }
1996              
1997 0         0 my $not_anchor = '';
1998              
1999 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2000             }
2001 0 0       0 if (scalar(@multipleoctet) >= 2) {
2002 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2003             }
2004             else {
2005 0         0 return $multipleoctet[0];
2006             }
2007             }
2008              
2009             #
2010             # Latin-9 open character list for not qr
2011             #
2012             sub charlist_not_qr {
2013              
2014 0     0 0 0 my $modifier = pop @_;
2015 0         0 my @char = @_;
2016              
2017 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2018 0         0 my @singleoctet = @$singleoctet;
2019 0         0 my @multipleoctet = @$multipleoctet;
2020              
2021             # with /i modifier
2022 0 0       0 if ($modifier =~ m/i/oxms) {
2023 0         0 my %singleoctet_ignorecase = ();
2024 0         0 for (@singleoctet) {
2025 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2026 0         0 for my $ord (hex($1) .. hex($2)) {
2027 0         0 my $char = CORE::chr($ord);
2028 0         0 my $uc = Char::Elatin9::uc($char);
2029 0         0 my $fc = Char::Elatin9::fc($char);
2030 0 0       0 if ($uc eq $fc) {
2031 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2032             }
2033             else {
2034 0 0       0 if (CORE::length($fc) == 1) {
2035 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2036 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2037             }
2038             else {
2039 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2040 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2041             }
2042             }
2043             }
2044             }
2045 0 0       0 if ($_ ne '') {
2046 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2047             }
2048             }
2049 0         0 my $i = 0;
2050 0         0 my @singleoctet_ignorecase = ();
2051 0         0 for my $ord (0 .. 255) {
2052 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2053 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2054             }
2055             else {
2056 0         0 $i++;
2057             }
2058             }
2059 0         0 @singleoctet = ();
2060 0         0 for my $range (@singleoctet_ignorecase) {
2061 0 0       0 if (ref $range) {
2062 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2063 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2064             }
2065             elsif (scalar(@{$range}) == 2) {
2066 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2067             }
2068             else {
2069 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2070             }
2071             }
2072             }
2073             }
2074              
2075             # return character list
2076 0 0       0 if (scalar(@multipleoctet) >= 1) {
2077 0 0       0 if (scalar(@singleoctet) >= 1) {
2078              
2079             # any character other than multiple-octet and single octet character class
2080 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2081             }
2082             else {
2083              
2084             # any character other than multiple-octet character class
2085 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2086             }
2087             }
2088             else {
2089 0 0       0 if (scalar(@singleoctet) >= 1) {
2090              
2091             # any character other than single octet character class
2092 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2093             }
2094             else {
2095              
2096             # any character
2097 0         0 return "(?:$your_char)";
2098             }
2099             }
2100             }
2101              
2102             #
2103             # open file in read mode
2104             #
2105             sub _open_r {
2106 197     197   701 my(undef,$file) = @_;
2107 197         821 $file =~ s#\A (\s) #./$1#oxms;
2108 197   33     26497 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2109             open($_[0],"< $file\0");
2110             }
2111              
2112             #
2113             # open file in write mode
2114             #
2115             sub _open_w {
2116 0     0   0 my(undef,$file) = @_;
2117 0         0 $file =~ s#\A (\s) #./$1#oxms;
2118 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2119             open($_[0],"> $file\0");
2120             }
2121              
2122             #
2123             # open file in append mode
2124             #
2125             sub _open_a {
2126 0     0   0 my(undef,$file) = @_;
2127 0         0 $file =~ s#\A (\s) #./$1#oxms;
2128 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2129             open($_[0],">> $file\0");
2130             }
2131              
2132             #
2133             # safe system
2134             #
2135             sub _systemx {
2136              
2137             # P.707 29.2.33. exec
2138             # in Chapter 29: Functions
2139             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2140             #
2141             # Be aware that in older releases of Perl, exec (and system) did not flush
2142             # your output buffer, so you needed to enable command buffering by setting $|
2143             # on one or more filehandles to avoid lost output in the case of exec, or
2144             # misordererd output in the case of system. This situation was largely remedied
2145             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2146              
2147             # P.855 exec
2148             # in Chapter 27: Functions
2149             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2150             #
2151             # In very old release of Perl (before v5.6), exec (and system) did not flush
2152             # your output buffer, so you needed to enable command buffering by setting $|
2153             # on one or more filehandles to avoid lost output with exec or misordered
2154             # output with system.
2155              
2156 197     197   805 $| = 1;
2157              
2158             # P.565 23.1.2. Cleaning Up Your Environment
2159             # in Chapter 23: Security
2160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2161              
2162             # P.656 Cleaning Up Your Environment
2163             # in Chapter 20: Security
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165              
2166             # local $ENV{'PATH'} = '.';
2167 197         2152 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2168              
2169             # P.707 29.2.33. exec
2170             # in Chapter 29: Functions
2171             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2172             #
2173             # As we mentioned earlier, exec treats a discrete list of arguments as an
2174             # indication that it should bypass shell processing. However, there is one
2175             # place where you might still get tripped up. The exec call (and system, too)
2176             # will not distinguish between a single scalar argument and an array containing
2177             # only one element.
2178             #
2179             # @args = ("echo surprise"); # just one element in list
2180             # exec @args # still subject to shell escapes
2181             # or die "exec: $!"; # because @args == 1
2182             #
2183             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2184             # first argument as the pathname, which forces the rest of the arguments to be
2185             # interpreted as a list, even if there is only one of them:
2186             #
2187             # exec { $args[0] } @args # safe even with one-argument list
2188             # or die "can't exec @args: $!";
2189              
2190             # P.855 exec
2191             # in Chapter 27: Functions
2192             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2193             #
2194             # As we mentioned earlier, exec treats a discrete list of arguments as a
2195             # directive to bypass shell processing. However, there is one place where
2196             # you might still get tripped up. The exec call (and system, too) cannot
2197             # 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             # || die "exec: $!"; # because @args == 1
2203             #
2204             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2205             # 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             # || die "can't exec @args: $!";
2210              
2211 197         400 return CORE::system { $_[0] } @_; # safe even with one-argument list
  197         23078802  
2212             }
2213              
2214             #
2215             # Latin-9 order to character (with parameter)
2216             #
2217             sub Char::Elatin9::chr(;$) {
2218              
2219 0 0   0 0   my $c = @_ ? $_[0] : $_;
2220              
2221 0 0         if ($c == 0x00) {
2222 0           return "\x00";
2223             }
2224             else {
2225 0           my @chr = ();
2226 0           while ($c > 0) {
2227 0           unshift @chr, ($c % 0x100);
2228 0           $c = int($c / 0x100);
2229             }
2230 0           return pack 'C*', @chr;
2231             }
2232             }
2233              
2234             #
2235             # Latin-9 order to character (without parameter)
2236             #
2237             sub Char::Elatin9::chr_() {
2238              
2239 0     0 0   my $c = $_;
2240              
2241 0 0         if ($c == 0x00) {
2242 0           return "\x00";
2243             }
2244             else {
2245 0           my @chr = ();
2246 0           while ($c > 0) {
2247 0           unshift @chr, ($c % 0x100);
2248 0           $c = int($c / 0x100);
2249             }
2250 0           return pack 'C*', @chr;
2251             }
2252             }
2253              
2254             #
2255             # Latin-9 path globbing (with parameter)
2256             #
2257             sub Char::Elatin9::glob($) {
2258              
2259 0 0   0 0   if (wantarray) {
2260 0           my @glob = _DOS_like_glob(@_);
2261 0           for my $glob (@glob) {
2262 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2263             }
2264 0           return @glob;
2265             }
2266             else {
2267 0           my $glob = _DOS_like_glob(@_);
2268 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2269 0           return $glob;
2270             }
2271             }
2272              
2273             #
2274             # Latin-9 path globbing (without parameter)
2275             #
2276             sub Char::Elatin9::glob_() {
2277              
2278 0 0   0 0   if (wantarray) {
2279 0           my @glob = _DOS_like_glob();
2280 0           for my $glob (@glob) {
2281 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2282             }
2283 0           return @glob;
2284             }
2285             else {
2286 0           my $glob = _DOS_like_glob();
2287 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2288 0           return $glob;
2289             }
2290             }
2291              
2292             #
2293             # Latin-9 path globbing via File::DosGlob 1.10
2294             #
2295             # Often I confuse "_dosglob" and "_doglob".
2296             # So, I renamed "_dosglob" to "_DOS_like_glob".
2297             #
2298             my %iter;
2299             my %entries;
2300             sub _DOS_like_glob {
2301              
2302             # context (keyed by second cxix argument provided by core)
2303 0     0     my($expr,$cxix) = @_;
2304              
2305             # glob without args defaults to $_
2306 0 0         $expr = $_ if not defined $expr;
2307              
2308             # represents the current user's home directory
2309             #
2310             # 7.3. Expanding Tildes in Filenames
2311             # in Chapter 7. File Access
2312             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2313             #
2314             # and File::HomeDir, File::HomeDir::Windows module
2315              
2316             # DOS-like system
2317 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2318 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2319 0           { my_home_MSWin32() }oxmse;
2320             }
2321              
2322             # UNIX-like system
2323             else {
2324 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2325 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2326             }
2327              
2328             # assume global context if not provided one
2329 0 0         $cxix = '_G_' if not defined $cxix;
2330 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2331              
2332             # if we're just beginning, do it all first
2333 0 0         if ($iter{$cxix} == 0) {
2334 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2335             }
2336              
2337             # chuck it all out, quick or slow
2338 0 0         if (wantarray) {
2339 0           delete $iter{$cxix};
2340 0           return @{delete $entries{$cxix}};
  0            
2341             }
2342             else {
2343 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2344 0           return shift @{$entries{$cxix}};
  0            
2345             }
2346             else {
2347             # return undef for EOL
2348 0           delete $iter{$cxix};
2349 0           delete $entries{$cxix};
2350 0           return undef;
2351             }
2352             }
2353             }
2354              
2355             #
2356             # Latin-9 path globbing subroutine
2357             #
2358             sub _do_glob {
2359              
2360 0     0     my($cond,@expr) = @_;
2361 0           my @glob = ();
2362 0           my $fix_drive_relative_paths = 0;
2363              
2364             OUTER:
2365 0           for my $expr (@expr) {
2366 0 0         next OUTER if not defined $expr;
2367 0 0         next OUTER if $expr eq '';
2368              
2369 0           my @matched = ();
2370 0           my @globdir = ();
2371 0           my $head = '.';
2372 0           my $pathsep = '/';
2373 0           my $tail;
2374              
2375             # if argument is within quotes strip em and do no globbing
2376 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2377 0           $expr = $1;
2378 0 0         if ($cond eq 'd') {
2379 0 0         if (-d $expr) {
2380 0           push @glob, $expr;
2381             }
2382             }
2383             else {
2384 0 0         if (-e $expr) {
2385 0           push @glob, $expr;
2386             }
2387             }
2388 0           next OUTER;
2389             }
2390              
2391             # wildcards with a drive prefix such as h:*.pm must be changed
2392             # to h:./*.pm to expand correctly
2393 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2394 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2395 0           $fix_drive_relative_paths = 1;
2396             }
2397             }
2398              
2399 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2400 0 0         if ($tail eq '') {
2401 0           push @glob, $expr;
2402 0           next OUTER;
2403             }
2404 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2405 0 0         if (@globdir = _do_glob('d', $head)) {
2406 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2407 0           next OUTER;
2408             }
2409             }
2410 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2411 0           $head .= $pathsep;
2412             }
2413 0           $expr = $tail;
2414             }
2415              
2416             # If file component has no wildcards, we can avoid opendir
2417 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2418 0 0         if ($head eq '.') {
2419 0           $head = '';
2420             }
2421 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2422 0           $head .= $pathsep;
2423             }
2424 0           $head .= $expr;
2425 0 0         if ($cond eq 'd') {
2426 0 0         if (-d $head) {
2427 0           push @glob, $head;
2428             }
2429             }
2430             else {
2431 0 0         if (-e $head) {
2432 0           push @glob, $head;
2433             }
2434             }
2435 0           next OUTER;
2436             }
2437 0 0         opendir(*DIR, $head) or next OUTER;
2438 0           my @leaf = readdir DIR;
2439 0           closedir DIR;
2440              
2441 0 0         if ($head eq '.') {
2442 0           $head = '';
2443             }
2444 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2445 0           $head .= $pathsep;
2446             }
2447              
2448 0           my $pattern = '';
2449 0           while ($expr =~ / \G ($q_char) /oxgc) {
2450 0           my $char = $1;
2451              
2452             # 6.9. Matching Shell Globs as Regular Expressions
2453             # in Chapter 6. Pattern Matching
2454             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2455             # (and so on)
2456              
2457 0 0         if ($char eq '*') {
    0          
    0          
2458 0           $pattern .= "(?:$your_char)*",
2459             }
2460             elsif ($char eq '?') {
2461 0           $pattern .= "(?:$your_char)?", # DOS style
2462             # $pattern .= "(?:$your_char)", # UNIX style
2463             }
2464             elsif ((my $fc = Char::Elatin9::fc($char)) ne $char) {
2465 0           $pattern .= $fc;
2466             }
2467             else {
2468 0           $pattern .= quotemeta $char;
2469             }
2470             }
2471 0     0     my $matchsub = sub { Char::Elatin9::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2472              
2473             # if ($@) {
2474             # print STDERR "$0: $@\n";
2475             # next OUTER;
2476             # }
2477              
2478             INNER:
2479 0           for my $leaf (@leaf) {
2480 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2481 0           next INNER;
2482             }
2483 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2484 0           next INNER;
2485             }
2486              
2487 0 0         if (&$matchsub($leaf)) {
2488 0           push @matched, "$head$leaf";
2489 0           next INNER;
2490             }
2491              
2492             # [DOS compatibility special case]
2493             # Failed, add a trailing dot and try again, but only...
2494              
2495 0 0 0       if (Char::Elatin9::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2496             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2497             Char::Elatin9::index($pattern,'\\.') != -1 # pattern has a dot.
2498             ) {
2499 0 0         if (&$matchsub("$leaf.")) {
2500 0           push @matched, "$head$leaf";
2501 0           next INNER;
2502             }
2503             }
2504             }
2505 0 0         if (@matched) {
2506 0           push @glob, @matched;
2507             }
2508             }
2509 0 0         if ($fix_drive_relative_paths) {
2510 0           for my $glob (@glob) {
2511 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2512             }
2513             }
2514 0           return @glob;
2515             }
2516              
2517             #
2518             # Latin-9 parse line
2519             #
2520             sub _parse_line {
2521              
2522 0     0     my($line) = @_;
2523              
2524 0           $line .= ' ';
2525 0           my @piece = ();
2526 0           while ($line =~ /
2527             " ( (?: [^"] )* ) " \s+ |
2528             ( (?: [^"\s] )* ) \s+
2529             /oxmsg
2530             ) {
2531 0 0         push @piece, defined($1) ? $1 : $2;
2532             }
2533 0           return @piece;
2534             }
2535              
2536             #
2537             # Latin-9 parse path
2538             #
2539             sub _parse_path {
2540              
2541 0     0     my($path,$pathsep) = @_;
2542              
2543 0           $path .= '/';
2544 0           my @subpath = ();
2545 0           while ($path =~ /
2546             ((?: [^\/\\] )+?) [\/\\]
2547             /oxmsg
2548             ) {
2549 0           push @subpath, $1;
2550             }
2551              
2552 0           my $tail = pop @subpath;
2553 0           my $head = join $pathsep, @subpath;
2554 0           return $head, $tail;
2555             }
2556              
2557             #
2558             # via File::HomeDir::Windows 1.00
2559             #
2560             sub my_home_MSWin32 {
2561              
2562             # A lot of unix people and unix-derived tools rely on
2563             # the ability to overload HOME. We will support it too
2564             # so that they can replace raw HOME calls with File::HomeDir.
2565 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2566 0           return $ENV{'HOME'};
2567             }
2568              
2569             # Do we have a user profile?
2570             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2571 0           return $ENV{'USERPROFILE'};
2572             }
2573              
2574             # Some Windows use something like $ENV{'HOME'}
2575             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2576 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2577             }
2578              
2579 0           return undef;
2580             }
2581              
2582             #
2583             # via File::HomeDir::Unix 1.00
2584             #
2585             sub my_home {
2586 0     0 0   my $home;
2587              
2588 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2589 0           $home = $ENV{'HOME'};
2590             }
2591              
2592             # This is from the original code, but I'm guessing
2593             # it means "login directory" and exists on some Unixes.
2594             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2595 0           $home = $ENV{'LOGDIR'};
2596             }
2597              
2598             ### More-desperate methods
2599              
2600             # Light desperation on any (Unixish) platform
2601             else {
2602 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2603             }
2604              
2605             # On Unix in general, a non-existant home means "no home"
2606             # For example, "nobody"-like users might use /nonexistant
2607 0 0 0       if (defined $home and ! -d($home)) {
2608 0           $home = undef;
2609             }
2610 0           return $home;
2611             }
2612              
2613             #
2614             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2615             #
2616             sub Char::Elatin9::PREMATCH {
2617 0     0 0   return $`;
2618             }
2619              
2620             #
2621             # ${^MATCH}, $MATCH, $& the string that matched
2622             #
2623             sub Char::Elatin9::MATCH {
2624 0     0 0   return $&;
2625             }
2626              
2627             #
2628             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2629             #
2630             sub Char::Elatin9::POSTMATCH {
2631 0     0 0   return $';
2632             }
2633              
2634             #
2635             # Latin-9 character to order (with parameter)
2636             #
2637             sub Char::Latin9::ord(;$) {
2638              
2639 0 0   0 1   local $_ = shift if @_;
2640              
2641 0 0         if (/\A ($q_char) /oxms) {
2642 0           my @ord = unpack 'C*', $1;
2643 0           my $ord = 0;
2644 0           while (my $o = shift @ord) {
2645 0           $ord = $ord * 0x100 + $o;
2646             }
2647 0           return $ord;
2648             }
2649             else {
2650 0           return CORE::ord $_;
2651             }
2652             }
2653              
2654             #
2655             # Latin-9 character to order (without parameter)
2656             #
2657             sub Char::Latin9::ord_() {
2658              
2659 0 0   0 0   if (/\A ($q_char) /oxms) {
2660 0           my @ord = unpack 'C*', $1;
2661 0           my $ord = 0;
2662 0           while (my $o = shift @ord) {
2663 0           $ord = $ord * 0x100 + $o;
2664             }
2665 0           return $ord;
2666             }
2667             else {
2668 0           return CORE::ord $_;
2669             }
2670             }
2671              
2672             #
2673             # Latin-9 reverse
2674             #
2675             sub Char::Latin9::reverse(@) {
2676              
2677 0 0   0 0   if (wantarray) {
2678 0           return CORE::reverse @_;
2679             }
2680             else {
2681              
2682             # One of us once cornered Larry in an elevator and asked him what
2683             # problem he was solving with this, but he looked as far off into
2684             # the distance as he could in an elevator and said, "It seemed like
2685             # a good idea at the time."
2686              
2687 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2688             }
2689             }
2690              
2691             #
2692             # Latin-9 getc (with parameter, without parameter)
2693             #
2694             sub Char::Latin9::getc(;*@) {
2695              
2696 0     0 0   my($package) = caller;
2697 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2698 0 0 0       croak 'Too many arguments for Char::Latin9::getc' if @_ and not wantarray;
2699              
2700 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2701 0           my $getc = '';
2702 0           for my $length ($length[0] .. $length[-1]) {
2703 0           $getc .= CORE::getc($fh);
2704 0 0         if (exists $range_tr{CORE::length($getc)}) {
2705 0 0         if ($getc =~ /\A ${Char::Elatin9::dot_s} \z/oxms) {
2706 0 0         return wantarray ? ($getc,@_) : $getc;
2707             }
2708             }
2709             }
2710 0 0         return wantarray ? ($getc,@_) : $getc;
2711             }
2712              
2713             #
2714             # Latin-9 length by character
2715             #
2716             sub Char::Latin9::length(;$) {
2717              
2718 0 0   0 1   local $_ = shift if @_;
2719              
2720 0           local @_ = /\G ($q_char) /oxmsg;
2721 0           return scalar @_;
2722             }
2723              
2724             #
2725             # Latin-9 substr by character
2726             #
2727             BEGIN {
2728              
2729             # P.232 The lvalue Attribute
2730             # in Chapter 6: Subroutines
2731             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2732              
2733             # P.336 The lvalue Attribute
2734             # in Chapter 7: Subroutines
2735             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2736              
2737             # P.144 8.4 Lvalue subroutines
2738             # in Chapter 8: perlsub: Perl subroutines
2739             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2740              
2741 197 50 0 197 1 171264 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            
2742             # vv----------------*******
2743             sub Char::Latin9::substr($$;$$) %s {
2744              
2745             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2746              
2747             # If the substring is beyond either end of the string, substr() returns the undefined
2748             # value and produces a warning. When used as an lvalue, specifying a substring that
2749             # is entirely outside the string raises an exception.
2750             # http://perldoc.perl.org/functions/substr.html
2751              
2752             # A return with no argument returns the scalar value undef in scalar context,
2753             # an empty list () in list context, and (naturally) nothing at all in void
2754             # context.
2755              
2756             my $offset = $_[1];
2757             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2758             return;
2759             }
2760              
2761             # substr($string,$offset,$length,$replacement)
2762             if (@_ == 4) {
2763             my(undef,undef,$length,$replacement) = @_;
2764             my $substr = join '', splice(@char, $offset, $length, $replacement);
2765             $_[0] = join '', @char;
2766              
2767             # return $substr; this doesn't work, don't say "return"
2768             $substr;
2769             }
2770              
2771             # substr($string,$offset,$length)
2772             elsif (@_ == 3) {
2773             my(undef,undef,$length) = @_;
2774             my $octet_offset = 0;
2775             my $octet_length = 0;
2776             if ($offset == 0) {
2777             $octet_offset = 0;
2778             }
2779             elsif ($offset > 0) {
2780             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2781             }
2782             else {
2783             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2784             }
2785             if ($length == 0) {
2786             $octet_length = 0;
2787             }
2788             elsif ($length > 0) {
2789             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2790             }
2791             else {
2792             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2793             }
2794             CORE::substr($_[0], $octet_offset, $octet_length);
2795             }
2796              
2797             # substr($string,$offset)
2798             else {
2799             my $octet_offset = 0;
2800             if ($offset == 0) {
2801             $octet_offset = 0;
2802             }
2803             elsif ($offset > 0) {
2804             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2805             }
2806             else {
2807             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset);
2810             }
2811             }
2812             END
2813             }
2814              
2815             #
2816             # Latin-9 index by character
2817             #
2818             sub Char::Latin9::index($$;$) {
2819              
2820 0     0 1   my $index;
2821 0 0         if (@_ == 3) {
2822 0           $index = Char::Elatin9::index($_[0], $_[1], CORE::length(Char::Latin9::substr($_[0], 0, $_[2])));
2823             }
2824             else {
2825 0           $index = Char::Elatin9::index($_[0], $_[1]);
2826             }
2827              
2828 0 0         if ($index == -1) {
2829 0           return -1;
2830             }
2831             else {
2832 0           return Char::Latin9::length(CORE::substr $_[0], 0, $index);
2833             }
2834             }
2835              
2836             #
2837             # Latin-9 rindex by character
2838             #
2839             sub Char::Latin9::rindex($$;$) {
2840              
2841 0     0 1   my $rindex;
2842 0 0         if (@_ == 3) {
2843 0           $rindex = Char::Elatin9::rindex($_[0], $_[1], CORE::length(Char::Latin9::substr($_[0], 0, $_[2])));
2844             }
2845             else {
2846 0           $rindex = Char::Elatin9::rindex($_[0], $_[1]);
2847             }
2848              
2849 0 0         if ($rindex == -1) {
2850 0           return -1;
2851             }
2852             else {
2853 0           return Char::Latin9::length(CORE::substr $_[0], 0, $rindex);
2854             }
2855             }
2856              
2857             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2858             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2859 197     197   22845 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  197     197   2635  
  197         417  
  197         16380  
2860              
2861             # ord() to ord() or Char::Latin9::ord()
2862 197     197   20084 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  197     197   1362  
  197         466  
  197         15679  
2863              
2864             # ord to ord or Char::Latin9::ord_
2865 197     197   11733 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  197     197   1348  
  197         402  
  197         13274  
2866              
2867             # reverse to reverse or Char::Latin9::reverse
2868 197     197   12335 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  197     197   1162  
  197         385  
  197         17977  
2869              
2870             # getc to getc or Char::Latin9::getc
2871 197     197   16464 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  197     197   1408  
  197         386  
  197         14858  
2872              
2873             # P.1023 Appendix W.9 Multibyte Anchoring
2874             # of ISBN 1-56592-224-7 CJKV Information Processing
2875              
2876             my $anchor = '';
2877              
2878 197     197   13098 BEGIN { CORE::eval q{ use vars qw($nest) } }
  197     197   1156  
  197         360  
  197         12058268  
2879              
2880             # regexp of nested parens in qqXX
2881              
2882             # P.340 Matching Nested Constructs with Embedded Code
2883             # in Chapter 7: Perl
2884             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2885              
2886             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2887             \\c[\x40-\x5F] |
2888             \\ [\x00-\xFF] |
2889             [^()] |
2890             \( (?{$nest++}) |
2891             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2892             }xms;
2893             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2894             \\c[\x40-\x5F] |
2895             \\ [\x00-\xFF] |
2896             [^{}] |
2897             \{ (?{$nest++}) |
2898             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2899             }xms;
2900             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2901             \\c[\x40-\x5F] |
2902             \\ [\x00-\xFF] |
2903             [^[\]] |
2904             \[ (?{$nest++}) |
2905             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2906             }xms;
2907             my $qq_angle = 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_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2915             (?: ::)? (?:
2916             [a-zA-Z_][a-zA-Z_0-9]*
2917             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2918             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2919             ))
2920             }xms;
2921             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2922             (?: ::)? (?:
2923             [0-9]+ |
2924             [^a-zA-Z_0-9\[\]] |
2925             ^[A-Z] |
2926             [a-zA-Z_][a-zA-Z_0-9]*
2927             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2928             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2929             ))
2930             }xms;
2931             my $qq_substr = qr{(?: Char::Latin9::substr | CORE::substr | substr ) \( $qq_paren \)
2932             }xms;
2933              
2934             # regexp of nested parens in qXX
2935             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2936             [^()] |
2937             \( (?{$nest++}) |
2938             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2939             }xms;
2940             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2941             [^{}] |
2942             \{ (?{$nest++}) |
2943             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2944             }xms;
2945             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2946             [^[\]] |
2947             \[ (?{$nest++}) |
2948             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2949             }xms;
2950             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2951             [^<>] |
2952             \< (?{$nest++}) |
2953             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2954             }xms;
2955              
2956             my $matched = '';
2957             my $s_matched = '';
2958              
2959             my $tr_variable = ''; # variable of tr///
2960             my $sub_variable = ''; # variable of s///
2961             my $bind_operator = ''; # =~ or !~
2962              
2963             my @heredoc = (); # here document
2964             my @heredoc_delimiter = ();
2965             my $here_script = ''; # here script
2966              
2967             #
2968             # escape Latin-9 script
2969             #
2970             sub Char::Latin9::escape(;$) {
2971 0 0   0 0   local($_) = $_[0] if @_;
2972              
2973             # P.359 The Study Function
2974             # in Chapter 7: Perl
2975             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2976              
2977 0           study $_; # Yes, I studied study yesterday.
2978              
2979             # while all script
2980              
2981             # 6.14. Matching from Where the Last Pattern Left Off
2982             # in Chapter 6. Pattern Matching
2983             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2984             # (and so on)
2985              
2986             # one member of Tag-team
2987             #
2988             # P.128 Start of match (or end of previous match): \G
2989             # P.130 Advanced Use of \G with Perl
2990             # in Chapter 3: Overview of Regular Expression Features and Flavors
2991             # P.255 Use leading anchors
2992             # P.256 Expose ^ and \G at the front expressions
2993             # in Chapter 6: Crafting an Efficient Expression
2994             # P.315 "Tag-team" matching with /gc
2995             # in Chapter 7: Perl
2996             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2997              
2998 0           my $e_script = '';
2999 0           while (not /\G \z/oxgc) { # member
3000 0           $e_script .= Char::Latin9::escape_token();
3001             }
3002              
3003 0           return $e_script;
3004             }
3005              
3006             #
3007             # escape Latin-9 token of script
3008             #
3009             sub Char::Latin9::escape_token {
3010              
3011             # \n output here document
3012              
3013 0     0 0   my $ignore_modules = join('|', qw(
3014             utf8
3015             bytes
3016             charnames
3017             I18N::Japanese
3018             I18N::Collate
3019             I18N::JExt
3020             File::DosGlob
3021             Wild
3022             Wildcard
3023             Japanese
3024             ));
3025              
3026             # another member of Tag-team
3027             #
3028             # P.315 "Tag-team" matching with /gc
3029             # in Chapter 7: Perl
3030             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3031              
3032 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          
3033 0           my $heredoc = '';
3034 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3035 0           $slash = 'm//';
3036              
3037 0           $heredoc = join '', @heredoc;
3038 0           @heredoc = ();
3039              
3040             # skip here document
3041 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3042 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3043             }
3044 0           @heredoc_delimiter = ();
3045              
3046 0           $here_script = '';
3047             }
3048 0           return "\n" . $heredoc;
3049             }
3050              
3051             # ignore space, comment
3052 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
3053              
3054             # if (, elsif (, unless (, while (, until (, given (, and when (
3055              
3056             # given, when
3057              
3058             # P.225 The given Statement
3059             # in Chapter 15: Smart Matching and given-when
3060             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3061              
3062             # P.133 The given Statement
3063             # in Chapter 4: Statements and Declarations
3064             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3065              
3066             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
3067 0           $slash = 'm//';
3068 0           return $1;
3069             }
3070              
3071             # scalar variable ($scalar = ...) =~ tr///;
3072             # scalar variable ($scalar = ...) =~ s///;
3073              
3074             # state
3075              
3076             # P.68 Persistent, Private Variables
3077             # in Chapter 4: Subroutines
3078             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3079              
3080             # P.160 Persistent Lexically Scoped Variables: state
3081             # in Chapter 4: Statements and Declarations
3082             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3083              
3084             # (and so on)
3085              
3086             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
3087 0           my $e_string = e_string($1);
3088              
3089 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3090 0           $tr_variable = $e_string . e_string($1);
3091 0           $bind_operator = $2;
3092 0           $slash = 'm//';
3093 0           return '';
3094             }
3095             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3096 0           $sub_variable = $e_string . e_string($1);
3097 0           $bind_operator = $2;
3098 0           $slash = 'm//';
3099 0           return '';
3100             }
3101             else {
3102 0           $slash = 'div';
3103 0           return $e_string;
3104             }
3105             }
3106              
3107             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin9::PREMATCH()
3108             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
3109 0           $slash = 'div';
3110 0           return q{Char::Elatin9::PREMATCH()};
3111             }
3112              
3113             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin9::MATCH()
3114             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
3115 0           $slash = 'div';
3116 0           return q{Char::Elatin9::MATCH()};
3117             }
3118              
3119             # $', ${'} --> $', ${'}
3120             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3121 0           $slash = 'div';
3122 0           return $1;
3123             }
3124              
3125             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin9::POSTMATCH()
3126             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
3127 0           $slash = 'div';
3128 0           return q{Char::Elatin9::POSTMATCH()};
3129             }
3130              
3131             # scalar variable $scalar =~ tr///;
3132             # scalar variable $scalar =~ s///;
3133             # substr() =~ tr///;
3134             # substr() =~ s///;
3135             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3136 0           my $scalar = e_string($1);
3137              
3138 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3139 0           $tr_variable = $scalar;
3140 0           $bind_operator = $1;
3141 0           $slash = 'm//';
3142 0           return '';
3143             }
3144             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3145 0           $sub_variable = $scalar;
3146 0           $bind_operator = $1;
3147 0           $slash = 'm//';
3148 0           return '';
3149             }
3150             else {
3151 0           $slash = 'div';
3152 0           return $scalar;
3153             }
3154             }
3155              
3156             # end of statement
3157             elsif (/\G ( [,;] ) /oxgc) {
3158 0           $slash = 'm//';
3159              
3160             # clear tr/// variable
3161 0           $tr_variable = '';
3162              
3163             # clear s/// variable
3164 0           $sub_variable = '';
3165              
3166 0           $bind_operator = '';
3167              
3168 0           return $1;
3169             }
3170              
3171             # bareword
3172             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
3173 0           return $1;
3174             }
3175              
3176             # $0 --> $0
3177             elsif (/\G ( \$ 0 ) /oxmsgc) {
3178 0           $slash = 'div';
3179 0           return $1;
3180             }
3181             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
3182 0           $slash = 'div';
3183 0           return $1;
3184             }
3185              
3186             # $$ --> $$
3187             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3188 0           $slash = 'div';
3189 0           return $1;
3190             }
3191              
3192             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3193             # $1, $2, $3 --> $1, $2, $3 otherwise
3194             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
3195 0           $slash = 'div';
3196 0           return e_capture($1);
3197             }
3198             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
3199 0           $slash = 'div';
3200 0           return e_capture($1);
3201             }
3202              
3203             # $$foo[ ... ] --> $ $foo->[ ... ]
3204             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
3205 0           $slash = 'div';
3206 0           return e_capture($1.'->'.$2);
3207             }
3208              
3209             # $$foo{ ... } --> $ $foo->{ ... }
3210             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
3211 0           $slash = 'div';
3212 0           return e_capture($1.'->'.$2);
3213             }
3214              
3215             # $$foo
3216             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
3217 0           $slash = 'div';
3218 0           return e_capture($1);
3219             }
3220              
3221             # ${ foo }
3222             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
3223 0           $slash = 'div';
3224 0           return '${' . $1 . '}';
3225             }
3226              
3227             # ${ ... }
3228             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
3229 0           $slash = 'div';
3230 0           return e_capture($1);
3231             }
3232              
3233             # variable or function
3234             # $ @ % & * $ #
3235             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) {
3236 0           $slash = 'div';
3237 0           return $1;
3238             }
3239             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3240             # $ @ # \ ' " / ? ( ) [ ] < >
3241             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3242 0           $slash = 'div';
3243 0           return $1;
3244             }
3245              
3246             # while ()
3247             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
3248 0           return $1;
3249             }
3250              
3251             # while () --- glob
3252              
3253             # avoid "Error: Runtime exception" of perl version 5.005_03
3254              
3255             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
3256 0           return 'while ($_ = Char::Elatin9::glob("' . $1 . '"))';
3257             }
3258              
3259             # while (glob)
3260             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
3261 0           return 'while ($_ = Char::Elatin9::glob_)';
3262             }
3263              
3264             # while (glob(WILDCARD))
3265             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
3266 0           return 'while ($_ = Char::Elatin9::glob';
3267             }
3268              
3269             # doit if, doit unless, doit while, doit until, doit for, doit when
3270 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3271              
3272             # subroutines of package Char::Elatin9
3273 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3274 0           elsif (/\G \b Char::Latin9::eval (?= \s* \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3275 0           elsif (/\G \b Char::Latin9::eval \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'eval Char::Latin9::escape'; }
  0            
3276 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3277 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::chop'; }
  0            
3278 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3279 0           elsif (/\G \b Char::Latin9::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin9::index'; }
  0            
3280 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::index'; }
  0            
3281 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3282 0           elsif (/\G \b Char::Latin9::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin9::rindex'; }
  0            
3283 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::rindex'; }
  0            
3284 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::lc'; }
  0            
3285 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::lcfirst'; }
  0            
3286 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::uc'; }
  0            
3287 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::ucfirst'; }
  0            
3288 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::fc'; }
  0            
3289              
3290             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3291 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3292 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3293 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3294 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3295 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3296 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3297 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3298              
3299 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3300 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3301 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3302 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3303 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3304 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3305 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3306              
3307             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3308 0           { $slash = 'm//'; return "-s $1"; }
  0            
3309 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3310 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3311 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3312              
3313 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3314 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3315 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::chr'; }
  0            
3316 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3317 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3318 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::glob'; }
  0            
3319 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::lc_'; }
  0            
3320 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::lcfirst_'; }
  0            
3321 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::uc_'; }
  0            
3322 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::ucfirst_'; }
  0            
3323 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::fc_'; }
  0            
3324 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3325              
3326 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3327 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3328 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::chr_'; }
  0            
3329 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3330 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3331 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin9::glob_'; }
  0            
3332 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3333 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3334             # split
3335             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
3336 0           $slash = 'm//';
3337              
3338 0           my $e = '';
3339 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
3340 0           $e .= $1;
3341             }
3342              
3343             # end of split
3344 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin9::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          
3345              
3346             # split scalar value
3347 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Elatin9::split' . $e . e_string($1); }
3348              
3349             # split literal space
3350 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Elatin9::split' . $e . qq {qq$1 $2}; }
3351 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; }
3352 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; }
3353 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; }
3354 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; }
3355 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; }
3356 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Elatin9::split' . $e . qq {q$1 $2}; }
3357 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; }
3358 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; }
3359 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; }
3360 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; }
3361 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; }
3362 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Elatin9::split' . $e . qq {' '}; }
3363 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Elatin9::split' . $e . qq {" "}; }
3364              
3365             # split qq//
3366             elsif (/\G \b (qq) \b /oxgc) {
3367 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3368             else {
3369 0           while (not /\G \z/oxgc) {
3370 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3371 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3372 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3373 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3374 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3375 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3376 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3377             }
3378 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3379             }
3380             }
3381              
3382             # split qr//
3383             elsif (/\G \b (qr) \b /oxgc) {
3384 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3385             else {
3386 0           while (not /\G \z/oxgc) {
3387 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3388 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3389 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3390 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3391 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3392 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3393 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3394 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3395             }
3396 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3397             }
3398             }
3399              
3400             # split q//
3401             elsif (/\G \b (q) \b /oxgc) {
3402 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3403             else {
3404 0           while (not /\G \z/oxgc) {
3405 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3406 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3407 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3408 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3409 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3410 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3411 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3412             }
3413 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3414             }
3415             }
3416              
3417             # split m//
3418             elsif (/\G \b (m) \b /oxgc) {
3419 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3420             else {
3421 0           while (not /\G \z/oxgc) {
3422 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3423 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3424 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3425 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3426 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3427 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3428 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3429 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3430             }
3431 0           die __FILE__, ": Search pattern not terminated";
3432             }
3433             }
3434              
3435             # split ''
3436             elsif (/\G (\') /oxgc) {
3437 0           my $q_string = '';
3438 0           while (not /\G \z/oxgc) {
3439 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3440 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3441 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3442 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3443             }
3444 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3445             }
3446              
3447             # split ""
3448             elsif (/\G (\") /oxgc) {
3449 0           my $qq_string = '';
3450 0           while (not /\G \z/oxgc) {
3451 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3452 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3453 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3454 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3455             }
3456 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3457             }
3458              
3459             # split //
3460             elsif (/\G (\/) /oxgc) {
3461 0           my $regexp = '';
3462 0           while (not /\G \z/oxgc) {
3463 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3464 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3465 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3466 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3467             }
3468 0           die __FILE__, ": Search pattern not terminated";
3469             }
3470             }
3471              
3472             # tr/// or y///
3473              
3474             # about [cdsrbB]* (/B modifier)
3475             #
3476             # P.559 appendix C
3477             # of ISBN 4-89052-384-7 Programming perl
3478             # (Japanese title is: Perl puroguramingu)
3479              
3480             elsif (/\G \b ( tr | y ) \b /oxgc) {
3481 0           my $ope = $1;
3482              
3483             # $1 $2 $3 $4 $5 $6
3484 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3485 0           my @tr = ($tr_variable,$2);
3486 0           return e_tr(@tr,'',$4,$6);
3487             }
3488             else {
3489 0           my $e = '';
3490 0           while (not /\G \z/oxgc) {
3491 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3492             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3493 0           my @tr = ($tr_variable,$2);
3494 0           while (not /\G \z/oxgc) {
3495 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3496 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3497 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3498 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3499 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3500 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3501             }
3502 0           die __FILE__, ": Transliteration replacement not terminated";
3503             }
3504             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3505 0           my @tr = ($tr_variable,$2);
3506 0           while (not /\G \z/oxgc) {
3507 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3508 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3509 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3510 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3511 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3512 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3513             }
3514 0           die __FILE__, ": Transliteration replacement not terminated";
3515             }
3516             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3517 0           my @tr = ($tr_variable,$2);
3518 0           while (not /\G \z/oxgc) {
3519 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3520 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3521 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3522 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3523 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3524 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3525             }
3526 0           die __FILE__, ": Transliteration replacement not terminated";
3527             }
3528             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3529 0           my @tr = ($tr_variable,$2);
3530 0           while (not /\G \z/oxgc) {
3531 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3532 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3533 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3534 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3535 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3536 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3537             }
3538 0           die __FILE__, ": Transliteration replacement not terminated";
3539             }
3540             # $1 $2 $3 $4 $5 $6
3541             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3542 0           my @tr = ($tr_variable,$2);
3543 0           return e_tr(@tr,'',$4,$6);
3544             }
3545             }
3546 0           die __FILE__, ": Transliteration pattern not terminated";
3547             }
3548             }
3549              
3550             # qq//
3551             elsif (/\G \b (qq) \b /oxgc) {
3552 0           my $ope = $1;
3553              
3554             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3555 0 0         if (/\G (\#) /oxgc) { # qq# #
3556 0           my $qq_string = '';
3557 0           while (not /\G \z/oxgc) {
3558 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3559 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3560 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3561 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3562             }
3563 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3564             }
3565              
3566             else {
3567 0           my $e = '';
3568 0           while (not /\G \z/oxgc) {
3569 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3570              
3571             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3572             elsif (/\G (\() /oxgc) { # qq ( )
3573 0           my $qq_string = '';
3574 0           local $nest = 1;
3575 0           while (not /\G \z/oxgc) {
3576 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3577 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3578 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3579             elsif (/\G (\)) /oxgc) {
3580 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3581 0           else { $qq_string .= $1; }
3582             }
3583 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3584             }
3585 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3586             }
3587              
3588             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3589             elsif (/\G (\{) /oxgc) { # qq { }
3590 0           my $qq_string = '';
3591 0           local $nest = 1;
3592 0           while (not /\G \z/oxgc) {
3593 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3594 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3595 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3596             elsif (/\G (\}) /oxgc) {
3597 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3598 0           else { $qq_string .= $1; }
3599             }
3600 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3601             }
3602 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3603             }
3604              
3605             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3606             elsif (/\G (\[) /oxgc) { # qq [ ]
3607 0           my $qq_string = '';
3608 0           local $nest = 1;
3609 0           while (not /\G \z/oxgc) {
3610 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3611 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3612 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3613             elsif (/\G (\]) /oxgc) {
3614 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3615 0           else { $qq_string .= $1; }
3616             }
3617 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3618             }
3619 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3620             }
3621              
3622             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3623             elsif (/\G (\<) /oxgc) { # qq < >
3624 0           my $qq_string = '';
3625 0           local $nest = 1;
3626 0           while (not /\G \z/oxgc) {
3627 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3628 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3629 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3630             elsif (/\G (\>) /oxgc) {
3631 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3632 0           else { $qq_string .= $1; }
3633             }
3634 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3635             }
3636 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3637             }
3638              
3639             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3640             elsif (/\G (\S) /oxgc) { # qq * *
3641 0           my $delimiter = $1;
3642 0           my $qq_string = '';
3643 0           while (not /\G \z/oxgc) {
3644 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3645 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3646 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3647 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3648             }
3649 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3650             }
3651             }
3652 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3653             }
3654             }
3655              
3656             # qr//
3657             elsif (/\G \b (qr) \b /oxgc) {
3658 0           my $ope = $1;
3659 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
3660 0           return e_qr($ope,$1,$3,$2,$4);
3661             }
3662             else {
3663 0           my $e = '';
3664 0           while (not /\G \z/oxgc) {
3665 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3666 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3667 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3668 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3669 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3670 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3671 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3672 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3673             }
3674 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3675             }
3676             }
3677              
3678             # qw//
3679             elsif (/\G \b (qw) \b /oxgc) {
3680 0           my $ope = $1;
3681 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3682 0           return e_qw($ope,$1,$3,$2);
3683             }
3684             else {
3685 0           my $e = '';
3686 0           while (not /\G \z/oxgc) {
3687 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3688              
3689 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3690 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3691              
3692 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3693 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3694              
3695 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3696 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3697              
3698 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3699 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3700              
3701 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3702 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3703             }
3704 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3705             }
3706             }
3707              
3708             # qx//
3709             elsif (/\G \b (qx) \b /oxgc) {
3710 0           my $ope = $1;
3711 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3712 0           return e_qq($ope,$1,$3,$2);
3713             }
3714             else {
3715 0           my $e = '';
3716 0           while (not /\G \z/oxgc) {
3717 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3718 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3719 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3720 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3721 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3722 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3723 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3724             }
3725 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3726             }
3727             }
3728              
3729             # q//
3730             elsif (/\G \b (q) \b /oxgc) {
3731 0           my $ope = $1;
3732              
3733             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3734              
3735             # avoid "Error: Runtime exception" of perl version 5.005_03
3736             # (and so on)
3737              
3738 0 0         if (/\G (\#) /oxgc) { # q# #
3739 0           my $q_string = '';
3740 0           while (not /\G \z/oxgc) {
3741 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3742 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3743 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3744 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3745             }
3746 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3747             }
3748              
3749             else {
3750 0           my $e = '';
3751 0           while (not /\G \z/oxgc) {
3752 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3753              
3754             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3755             elsif (/\G (\() /oxgc) { # q ( )
3756 0           my $q_string = '';
3757 0           local $nest = 1;
3758 0           while (not /\G \z/oxgc) {
3759 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3760 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3761 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3762 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3763             elsif (/\G (\)) /oxgc) {
3764 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3765 0           else { $q_string .= $1; }
3766             }
3767 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3768             }
3769 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3770             }
3771              
3772             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3773             elsif (/\G (\{) /oxgc) { # q { }
3774 0           my $q_string = '';
3775 0           local $nest = 1;
3776 0           while (not /\G \z/oxgc) {
3777 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3778 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3779 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3780 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3781             elsif (/\G (\}) /oxgc) {
3782 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3783 0           else { $q_string .= $1; }
3784             }
3785 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3786             }
3787 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3788             }
3789              
3790             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3791             elsif (/\G (\[) /oxgc) { # q [ ]
3792 0           my $q_string = '';
3793 0           local $nest = 1;
3794 0           while (not /\G \z/oxgc) {
3795 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3796 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3797 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3798 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3799             elsif (/\G (\]) /oxgc) {
3800 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3801 0           else { $q_string .= $1; }
3802             }
3803 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3804             }
3805 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3806             }
3807              
3808             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3809             elsif (/\G (\<) /oxgc) { # q < >
3810 0           my $q_string = '';
3811 0           local $nest = 1;
3812 0           while (not /\G \z/oxgc) {
3813 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3814 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3815 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3816 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3817             elsif (/\G (\>) /oxgc) {
3818 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3819 0           else { $q_string .= $1; }
3820             }
3821 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3822             }
3823 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3824             }
3825              
3826             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3827             elsif (/\G (\S) /oxgc) { # q * *
3828 0           my $delimiter = $1;
3829 0           my $q_string = '';
3830 0           while (not /\G \z/oxgc) {
3831 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3832 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3833 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3834 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3835             }
3836 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3837             }
3838             }
3839 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3840             }
3841             }
3842              
3843             # m//
3844             elsif (/\G \b (m) \b /oxgc) {
3845 0           my $ope = $1;
3846 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
3847 0           return e_qr($ope,$1,$3,$2,$4);
3848             }
3849             else {
3850 0           my $e = '';
3851 0           while (not /\G \z/oxgc) {
3852 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3853 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3854 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3855 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3856 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3857 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3858 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3859 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3860 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3861             }
3862 0           die __FILE__, ": Search pattern not terminated";
3863             }
3864             }
3865              
3866             # s///
3867              
3868             # about [cegimosxpradlubB]* (/cg modifier)
3869             #
3870             # P.67 Pattern-Matching Operators
3871             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3872              
3873             elsif (/\G \b (s) \b /oxgc) {
3874 0           my $ope = $1;
3875              
3876             # $1 $2 $3 $4 $5 $6
3877 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
3878 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3879             }
3880             else {
3881 0           my $e = '';
3882 0           while (not /\G \z/oxgc) {
3883 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3884             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3885 0           my @s = ($1,$2,$3);
3886 0           while (not /\G \z/oxgc) {
3887 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3888             # $1 $2 $3 $4
3889 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3890 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3891 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3892 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3893 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3894 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3895 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3896 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3897 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3898             }
3899 0           die __FILE__, ": Substitution replacement not terminated";
3900             }
3901             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3902 0           my @s = ($1,$2,$3);
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          
    0          
3905             # $1 $2 $3 $4
3906 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3907 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3908 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3909 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3910 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3911 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915             }
3916 0           die __FILE__, ": Substitution replacement not terminated";
3917             }
3918             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3919 0           my @s = ($1,$2,$3);
3920 0           while (not /\G \z/oxgc) {
3921 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3922             # $1 $2 $3 $4
3923 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930             }
3931 0           die __FILE__, ": Substitution replacement not terminated";
3932             }
3933             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3934 0           my @s = ($1,$2,$3);
3935 0           while (not /\G \z/oxgc) {
3936 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3937             # $1 $2 $3 $4
3938 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947             }
3948 0           die __FILE__, ": Substitution replacement not terminated";
3949             }
3950             # $1 $2 $3 $4 $5 $6
3951             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
3952 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3953             }
3954             # $1 $2 $3 $4 $5 $6
3955             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3956 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3957             }
3958             # $1 $2 $3 $4 $5 $6
3959             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3960 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3961             }
3962             # $1 $2 $3 $4 $5 $6
3963             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3964 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3965             }
3966             }
3967 0           die __FILE__, ": Substitution pattern not terminated";
3968             }
3969             }
3970              
3971             # require ignore module
3972 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3973 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3974 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3975              
3976             # use strict; --> use strict; no strict qw(refs);
3977 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3978 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3979 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3980              
3981             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
3982             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3983 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
3984 0           return "use $1; no strict qw(refs);";
3985             }
3986             else {
3987 0           return "use $1;";
3988             }
3989             }
3990             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3991 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
3992 0           return "use $1; no strict qw(refs);";
3993             }
3994             else {
3995 0           return "use $1;";
3996             }
3997             }
3998              
3999             # ignore use module
4000 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4001 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4002 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4003              
4004             # ignore no module
4005 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4006 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4007 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4008              
4009             # use else
4010 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4011              
4012             # use else
4013 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4014              
4015             # ''
4016             elsif (/\G (?
4017 0           my $q_string = '';
4018 0           while (not /\G \z/oxgc) {
4019 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4020 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4021 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4022 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4023             }
4024 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4025             }
4026              
4027             # ""
4028             elsif (/\G (\") /oxgc) {
4029 0           my $qq_string = '';
4030 0           while (not /\G \z/oxgc) {
4031 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4032 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4033 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4034 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4035             }
4036 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4037             }
4038              
4039             # ``
4040             elsif (/\G (\`) /oxgc) {
4041 0           my $qx_string = '';
4042 0           while (not /\G \z/oxgc) {
4043 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4044 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4045 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4046 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4047             }
4048 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4049             }
4050              
4051             # // --- not divide operator (num / num), not defined-or
4052             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4053 0           my $regexp = '';
4054 0           while (not /\G \z/oxgc) {
4055 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4056 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4057 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4058 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4059             }
4060 0           die __FILE__, ": Search pattern not terminated";
4061             }
4062              
4063             # ?? --- not conditional operator (condition ? then : else)
4064             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4065 0           my $regexp = '';
4066 0           while (not /\G \z/oxgc) {
4067 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4068 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4069 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4070 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4071             }
4072 0           die __FILE__, ": Search pattern not terminated";
4073             }
4074              
4075             # << (bit shift) --- not here document
4076 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4077              
4078             # <<'HEREDOC'
4079             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4080 0           $slash = 'm//';
4081 0           my $here_quote = $1;
4082 0           my $delimiter = $2;
4083              
4084             # get here document
4085 0 0         if ($here_script eq '') {
4086 0           $here_script = CORE::substr $_, pos $_;
4087 0           $here_script =~ s/.*?\n//oxm;
4088             }
4089 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4090 0           push @heredoc, $1 . qq{\n$delimiter\n};
4091 0           push @heredoc_delimiter, $delimiter;
4092             }
4093             else {
4094 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4095             }
4096 0           return $here_quote;
4097             }
4098              
4099             # <<\HEREDOC
4100              
4101             # P.66 2.6.6. "Here" Documents
4102             # in Chapter 2: Bits and Pieces
4103             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4104              
4105             # P.73 "Here" Documents
4106             # in Chapter 2: Bits and Pieces
4107             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4108              
4109             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4110 0           $slash = 'm//';
4111 0           my $here_quote = $1;
4112 0           my $delimiter = $2;
4113              
4114             # get here document
4115 0 0         if ($here_script eq '') {
4116 0           $here_script = CORE::substr $_, pos $_;
4117 0           $here_script =~ s/.*?\n//oxm;
4118             }
4119 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4120 0           push @heredoc, $1 . qq{\n$delimiter\n};
4121 0           push @heredoc_delimiter, $delimiter;
4122             }
4123             else {
4124 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4125             }
4126 0           return $here_quote;
4127             }
4128              
4129             # <<"HEREDOC"
4130             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, e_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             # <
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             # <<`HEREDOC`
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             # <<= <=> <= < operator
4193             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4194 0           return $1;
4195             }
4196              
4197             #
4198             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4199 0           return $1;
4200             }
4201              
4202             # --- glob
4203              
4204             # avoid "Error: Runtime exception" of perl version 5.005_03
4205              
4206             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4207 0           return 'Char::Elatin9::glob("' . $1 . '")';
4208             }
4209              
4210             # __DATA__
4211 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4212              
4213             # __END__
4214 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4215              
4216             # \cD Control-D
4217              
4218             # P.68 2.6.8. Other Literal Tokens
4219             # in Chapter 2: Bits and Pieces
4220             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4221              
4222             # P.76 Other Literal Tokens
4223             # in Chapter 2: Bits and Pieces
4224             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4225              
4226 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4227              
4228             # \cZ Control-Z
4229 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4230              
4231             # any operator before div
4232             elsif (/\G (
4233             -- | \+\+ |
4234             [\)\}\]]
4235              
4236 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4237              
4238             # yada-yada or triple-dot operator
4239             elsif (/\G (
4240             \.\.\.
4241              
4242 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4243              
4244             # any operator before m//
4245              
4246             # //, //= (defined-or)
4247              
4248             # P.164 Logical Operators
4249             # in Chapter 10: More Control Structures
4250             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4251              
4252             # P.119 C-Style Logical (Short-Circuit) Operators
4253             # in Chapter 3: Unary and Binary Operators
4254             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4255              
4256             # (and so on)
4257              
4258             # ~~
4259              
4260             # P.221 The Smart Match Operator
4261             # in Chapter 15: Smart Matching and given-when
4262             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4263              
4264             # P.112 Smartmatch Operator
4265             # in Chapter 3: Unary and Binary Operators
4266             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4267              
4268             # (and so on)
4269              
4270             elsif (/\G (
4271              
4272             !~~ | !~ | != | ! |
4273             %= | % |
4274             &&= | && | &= | & |
4275             -= | -> | - |
4276             :\s*= |
4277             : |
4278             <<= | <=> | <= | < |
4279             == | => | =~ | = |
4280             >>= | >> | >= | > |
4281             \*\*= | \*\* | \*= | \* |
4282             \+= | \+ |
4283             \.\. | \.= | \. |
4284             \/\/= | \/\/ |
4285             \/= | \/ |
4286             \? |
4287             \\ |
4288             \^= | \^ |
4289             \b x= |
4290             \|\|= | \|\| | \|= | \| |
4291             ~~ | ~ |
4292             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4293             \b(?: print )\b |
4294              
4295             [,;\(\{\[]
4296              
4297 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4298              
4299             # other any character
4300 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4301              
4302             # system error
4303             else {
4304 0           die __FILE__, ": Oops, this shouldn't happen!";
4305             }
4306             }
4307              
4308             # escape Latin-9 string
4309             sub e_string {
4310 0     0 0   my($string) = @_;
4311 0           my $e_string = '';
4312              
4313 0           local $slash = 'm//';
4314              
4315             # P.1024 Appendix W.10 Multibyte Processing
4316             # of ISBN 1-56592-224-7 CJKV Information Processing
4317             # (and so on)
4318              
4319 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
4320              
4321             # without { ... }
4322 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4323 0 0         if ($string !~ /<
4324 0           return $string;
4325             }
4326             }
4327              
4328             E_STRING_LOOP:
4329 0           while ($string !~ /\G \z/oxgc) {
4330 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          
4331             }
4332              
4333             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Elatin9::PREMATCH()]}
4334 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
4335 0           $e_string .= q{Char::Elatin9::PREMATCH()};
4336 0           $slash = 'div';
4337             }
4338              
4339             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Elatin9::MATCH()]}
4340             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
4341 0           $e_string .= q{Char::Elatin9::MATCH()};
4342 0           $slash = 'div';
4343             }
4344              
4345             # $', ${'} --> $', ${'}
4346             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4347 0           $e_string .= $1;
4348 0           $slash = 'div';
4349             }
4350              
4351             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Elatin9::POSTMATCH()]}
4352             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
4353 0           $e_string .= q{Char::Elatin9::POSTMATCH()};
4354 0           $slash = 'div';
4355             }
4356              
4357             # bareword
4358             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
4359 0           $e_string .= $1;
4360 0           $slash = 'div';
4361             }
4362              
4363             # $0 --> $0
4364             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4365 0           $e_string .= $1;
4366 0           $slash = 'div';
4367             }
4368             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
4369 0           $e_string .= $1;
4370 0           $slash = 'div';
4371             }
4372              
4373             # $$ --> $$
4374             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4375 0           $e_string .= $1;
4376 0           $slash = 'div';
4377             }
4378              
4379             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4380             # $1, $2, $3 --> $1, $2, $3 otherwise
4381             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
4382 0           $e_string .= e_capture($1);
4383 0           $slash = 'div';
4384             }
4385             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
4386 0           $e_string .= e_capture($1);
4387 0           $slash = 'div';
4388             }
4389              
4390             # $$foo[ ... ] --> $ $foo->[ ... ]
4391             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
4392 0           $e_string .= e_capture($1.'->'.$2);
4393 0           $slash = 'div';
4394             }
4395              
4396             # $$foo{ ... } --> $ $foo->{ ... }
4397             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
4398 0           $e_string .= e_capture($1.'->'.$2);
4399 0           $slash = 'div';
4400             }
4401              
4402             # $$foo
4403             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
4404 0           $e_string .= e_capture($1);
4405 0           $slash = 'div';
4406             }
4407              
4408             # ${ foo }
4409             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
4410 0           $e_string .= '${' . $1 . '}';
4411 0           $slash = 'div';
4412             }
4413              
4414             # ${ ... }
4415             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
4416 0           $e_string .= e_capture($1);
4417 0           $slash = 'div';
4418             }
4419              
4420             # variable or function
4421             # $ @ % & * $ #
4422             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) {
4423 0           $e_string .= $1;
4424 0           $slash = 'div';
4425             }
4426             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4427             # $ @ # \ ' " / ? ( ) [ ] < >
4428             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4429 0           $e_string .= $1;
4430 0           $slash = 'div';
4431             }
4432              
4433             # subroutines of package Char::Elatin9
4434 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4435 0           elsif ($string =~ /\G \b Char::Latin9::eval (?= \s* \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4436 0           elsif ($string =~ /\G \b Char::Latin9::eval \b /oxgc) { $e_string .= 'eval Char::Latin9::escape'; $slash = 'm//'; }
  0            
4437 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4438 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Elatin9::chop'; $slash = 'm//'; }
  0            
4439 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4440 0           elsif ($string =~ /\G \b Char::Latin9::index \b /oxgc) { $e_string .= 'Char::Latin9::index'; $slash = 'm//'; }
  0            
4441 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Elatin9::index'; $slash = 'm//'; }
  0            
4442 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4443 0           elsif ($string =~ /\G \b Char::Latin9::rindex \b /oxgc) { $e_string .= 'Char::Latin9::rindex'; $slash = 'm//'; }
  0            
4444 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Elatin9::rindex'; $slash = 'm//'; }
  0            
4445 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin9::lc'; $slash = 'm//'; }
  0            
4446 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin9::lcfirst'; $slash = 'm//'; }
  0            
4447 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin9::uc'; $slash = 'm//'; }
  0            
4448 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin9::ucfirst'; $slash = 'm//'; }
  0            
4449 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin9::fc'; $slash = 'm//'; }
  0            
4450              
4451             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4452 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4453 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4454 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4455 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4456 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4457 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4458 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            
4459              
4460 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4461 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4462 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4463 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4464 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4465 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4466 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            
4467              
4468             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
4469 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4470 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4471 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4472 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4473              
4474 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4475 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4476 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin9::chr'; $slash = 'm//'; }
  0            
4477 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4478 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4479 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin9::glob'; $slash = 'm//'; }
  0            
4480 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Elatin9::lc_'; $slash = 'm//'; }
  0            
4481 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Elatin9::lcfirst_'; $slash = 'm//'; }
  0            
4482 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Elatin9::uc_'; $slash = 'm//'; }
  0            
4483 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Elatin9::ucfirst_'; $slash = 'm//'; }
  0            
4484 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Elatin9::fc_'; $slash = 'm//'; }
  0            
4485 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4486              
4487 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4488 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4489 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Elatin9::chr_'; $slash = 'm//'; }
  0            
4490 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4491 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4492 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Elatin9::glob_'; $slash = 'm//'; }
  0            
4493 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4494 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4495             # split
4496             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
4497 0           $slash = 'm//';
4498              
4499 0           my $e = '';
4500 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
4501 0           $e .= $1;
4502             }
4503              
4504             # end of split
4505 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin9::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          
4506              
4507             # split scalar value
4508 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4509              
4510             # split literal space
4511 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4512 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4513 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4514 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4515 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4516 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4517 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4518 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4519 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4520 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4521 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4522 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4523 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4524 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Elatin9::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4525              
4526             # split qq//
4527             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4528 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            
4529             else {
4530 0           while ($string !~ /\G \z/oxgc) {
4531 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4532 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4533 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4534 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4535 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4536 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4537 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            
4538             }
4539 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4540             }
4541             }
4542              
4543             # split qr//
4544             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4545 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            
4546             else {
4547 0           while ($string !~ /\G \z/oxgc) {
4548 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4549 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4550 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4551 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4552 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4553 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            
4554 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4555 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            
4556             }
4557 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4558             }
4559             }
4560              
4561             # split q//
4562             elsif ($string =~ /\G \b (q) \b /oxgc) {
4563 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            
4564             else {
4565 0           while ($string !~ /\G \z/oxgc) {
4566 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4567 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4568 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4569 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4570 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4571 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4572 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            
4573             }
4574 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4575             }
4576             }
4577              
4578             # split m//
4579             elsif ($string =~ /\G \b (m) \b /oxgc) {
4580 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            
4581             else {
4582 0           while ($string !~ /\G \z/oxgc) {
4583 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4584 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            
4585 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            
4586 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            
4587 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            
4588 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            
4589 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4590 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            
4591             }
4592 0           die __FILE__, ": Search pattern not terminated";
4593             }
4594             }
4595              
4596             # split ''
4597             elsif ($string =~ /\G (\') /oxgc) {
4598 0           my $q_string = '';
4599 0           while ($string !~ /\G \z/oxgc) {
4600 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4601 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4602 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4603 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4604             }
4605 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4606             }
4607              
4608             # split ""
4609             elsif ($string =~ /\G (\") /oxgc) {
4610 0           my $qq_string = '';
4611 0           while ($string !~ /\G \z/oxgc) {
4612 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4613 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4614 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4615 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4616             }
4617 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4618             }
4619              
4620             # split //
4621             elsif ($string =~ /\G (\/) /oxgc) {
4622 0           my $regexp = '';
4623 0           while ($string !~ /\G \z/oxgc) {
4624 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4625 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4626 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4627 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4628             }
4629 0           die __FILE__, ": Search pattern not terminated";
4630             }
4631             }
4632              
4633             # qq//
4634             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4635 0           my $ope = $1;
4636 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4637 0           $e_string .= e_qq($ope,$1,$3,$2);
4638             }
4639             else {
4640 0           my $e = '';
4641 0           while ($string !~ /\G \z/oxgc) {
4642 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4643 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4644 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4645 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4646 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4647 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4648             }
4649 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4650             }
4651             }
4652              
4653             # qx//
4654             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4655 0           my $ope = $1;
4656 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4657 0           $e_string .= e_qq($ope,$1,$3,$2);
4658             }
4659             else {
4660 0           my $e = '';
4661 0           while ($string !~ /\G \z/oxgc) {
4662 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4663 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4664 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4665 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4666 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4667 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4668 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4669             }
4670 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4671             }
4672             }
4673              
4674             # q//
4675             elsif ($string =~ /\G \b (q) \b /oxgc) {
4676 0           my $ope = $1;
4677 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4678 0           $e_string .= e_q($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          
4684 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4685 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4686 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4687 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4688 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            
4689             }
4690 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4691             }
4692             }
4693              
4694             # ''
4695 0           elsif ($string =~ /\G (?
4696              
4697             # ""
4698 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4699              
4700             # ``
4701 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4702              
4703             # <<= <=> <= < operator
4704             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
4705 0           { $e_string .= $1; }
4706              
4707             #
4708 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4709              
4710             # --- glob
4711             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4712 0           $e_string .= 'Char::Elatin9::glob("' . $1 . '")';
4713             }
4714              
4715             # << (bit shift) --- not here document
4716 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4717              
4718             # <<'HEREDOC'
4719             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4720 0           $slash = 'm//';
4721 0           my $here_quote = $1;
4722 0           my $delimiter = $2;
4723              
4724             # get here document
4725 0 0         if ($here_script eq '') {
4726 0           $here_script = CORE::substr $_, pos $_;
4727 0           $here_script =~ s/.*?\n//oxm;
4728             }
4729 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4730 0           push @heredoc, $1 . qq{\n$delimiter\n};
4731 0           push @heredoc_delimiter, $delimiter;
4732             }
4733             else {
4734 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4735             }
4736 0           $e_string .= $here_quote;
4737             }
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, e_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             # <
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             # <<`HEREDOC`
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             # any operator before div
4824             elsif ($string =~ /\G (
4825             -- | \+\+ |
4826             [\)\}\]]
4827              
4828 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4829              
4830             # yada-yada or triple-dot operator
4831             elsif ($string =~ /\G (
4832             \.\.\.
4833              
4834 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4835              
4836             # any operator before m//
4837             elsif ($string =~ /\G (
4838              
4839             !~~ | !~ | != | ! |
4840             %= | % |
4841             &&= | && | &= | & |
4842             -= | -> | - |
4843             :\s*= |
4844             : |
4845             <<= | <=> | <= | < |
4846             == | => | =~ | = |
4847             >>= | >> | >= | > |
4848             \*\*= | \*\* | \*= | \* |
4849             \+= | \+ |
4850             \.\. | \.= | \. |
4851             \/\/= | \/\/ |
4852             \/= | \/ |
4853             \? |
4854             \\ |
4855             \^= | \^ |
4856             \b x= |
4857             \|\|= | \|\| | \|= | \| |
4858             ~~ | ~ |
4859             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4860             \b(?: print )\b |
4861              
4862             [,;\(\{\[]
4863              
4864 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4865              
4866             # other any character
4867 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4868              
4869             # system error
4870             else {
4871 0           die __FILE__, ": Oops, this shouldn't happen!";
4872             }
4873             }
4874              
4875 0           return $e_string;
4876             }
4877              
4878             #
4879             # character class
4880             #
4881             sub character_class {
4882 0     0 0   my($char,$modifier) = @_;
4883              
4884 0 0         if ($char eq '.') {
4885 0 0         if ($modifier =~ /s/) {
4886 0           return '${Char::Elatin9::dot_s}';
4887             }
4888             else {
4889 0           return '${Char::Elatin9::dot}';
4890             }
4891             }
4892             else {
4893 0           return Char::Elatin9::classic_character_class($char);
4894             }
4895             }
4896              
4897             #
4898             # escape capture ($1, $2, $3, ...)
4899             #
4900             sub e_capture {
4901              
4902 0     0 0   return join '', '${', $_[0], '}';
4903             }
4904              
4905             #
4906             # escape transliteration (tr/// or y///)
4907             #
4908             sub e_tr {
4909 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4910 0           my $e_tr = '';
4911 0   0       $modifier ||= '';
4912              
4913 0           $slash = 'div';
4914              
4915             # quote character class 1
4916 0           $charclass = q_tr($charclass);
4917              
4918             # quote character class 2
4919 0           $charclass2 = q_tr($charclass2);
4920              
4921             # /b /B modifier
4922 0 0         if ($modifier =~ tr/bB//d) {
4923 0 0         if ($variable eq '') {
4924 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4925             }
4926             else {
4927 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4928             }
4929             }
4930             else {
4931 0 0         if ($variable eq '') {
4932 0           $e_tr = qq{Char::Elatin9::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4933             }
4934             else {
4935 0           $e_tr = qq{Char::Elatin9::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4936             }
4937             }
4938              
4939             # clear tr/// variable
4940 0           $tr_variable = '';
4941 0           $bind_operator = '';
4942              
4943 0           return $e_tr;
4944             }
4945              
4946             #
4947             # quote for escape transliteration (tr/// or y///)
4948             #
4949             sub q_tr {
4950 0     0 0   my($charclass) = @_;
4951              
4952             # quote character class
4953 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4954 0           return e_q('', "'", "'", $charclass); # --> q' '
4955             }
4956             elsif ($charclass !~ /\//oxms) {
4957 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4958             }
4959             elsif ($charclass !~ /\#/oxms) {
4960 0           return e_q('q', '#', '#', $charclass); # --> q# #
4961             }
4962             elsif ($charclass !~ /[\<\>]/oxms) {
4963 0           return e_q('q', '<', '>', $charclass); # --> q< >
4964             }
4965             elsif ($charclass !~ /[\(\)]/oxms) {
4966 0           return e_q('q', '(', ')', $charclass); # --> q( )
4967             }
4968             elsif ($charclass !~ /[\{\}]/oxms) {
4969 0           return e_q('q', '{', '}', $charclass); # --> q{ }
4970             }
4971             else {
4972 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4973 0 0         if ($charclass !~ /\Q$char\E/xms) {
4974 0           return e_q('q', $char, $char, $charclass);
4975             }
4976             }
4977             }
4978              
4979 0           return e_q('q', '{', '}', $charclass);
4980             }
4981              
4982             #
4983             # escape q string (q//, '')
4984             #
4985             sub e_q {
4986 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4987              
4988 0           $slash = 'div';
4989              
4990 0           return join '', $ope, $delimiter, $string, $end_delimiter;
4991             }
4992              
4993             #
4994             # escape qq string (qq//, "", qx//, ``)
4995             #
4996             sub e_qq {
4997 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4998              
4999 0           $slash = 'div';
5000              
5001 0           my $left_e = 0;
5002 0           my $right_e = 0;
5003 0           my @char = $string =~ /\G(
5004             \\o\{ [0-7]+ \} |
5005             \\x\{ [0-9A-Fa-f]+ \} |
5006             \\N\{ [^0-9\}][^\}]* \} |
5007             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5008             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5009             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5010             \$ \s* \d+ |
5011             \$ \s* \{ \s* \d+ \s* \} |
5012             \$ \$ (?![\w\{]) |
5013             \$ \s* \$ \s* $qq_variable |
5014             \\?(?:$q_char)
5015             )/oxmsg;
5016              
5017 0           for (my $i=0; $i <= $#char; $i++) {
5018              
5019             # "\L\u" --> "\u\L"
5020 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5021 0           @char[$i,$i+1] = @char[$i+1,$i];
5022             }
5023              
5024             # "\U\l" --> "\l\U"
5025             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5026 0           @char[$i,$i+1] = @char[$i+1,$i];
5027             }
5028              
5029             # octal escape sequence
5030             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5031 0           $char[$i] = Char::Elatin9::octchr($1);
5032             }
5033              
5034             # hexadecimal escape sequence
5035             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5036 0           $char[$i] = Char::Elatin9::hexchr($1);
5037             }
5038              
5039             # \N{CHARNAME} --> N{CHARNAME}
5040             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5041 0           $char[$i] = $1;
5042             }
5043              
5044 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          
5045             }
5046              
5047             # \F
5048             #
5049             # P.69 Table 2-6. Translation escapes
5050             # in Chapter 2: Bits and Pieces
5051             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5052             # (and so on)
5053              
5054             # \u \l \U \L \F \Q \E
5055 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5056 0 0         if ($right_e < $left_e) {
5057 0           $char[$i] = '\\' . $char[$i];
5058             }
5059             }
5060             elsif ($char[$i] eq '\u') {
5061              
5062             # "STRING @{[ LIST EXPR ]} MORE STRING"
5063              
5064             # P.257 Other Tricks You Can Do with Hard References
5065             # in Chapter 8: References
5066             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5067              
5068             # P.353 Other Tricks You Can Do with Hard References
5069             # in Chapter 8: References
5070             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5071              
5072             # (and so on)
5073              
5074 0           $char[$i] = '@{[Char::Elatin9::ucfirst qq<';
5075 0           $left_e++;
5076             }
5077             elsif ($char[$i] eq '\l') {
5078 0           $char[$i] = '@{[Char::Elatin9::lcfirst qq<';
5079 0           $left_e++;
5080             }
5081             elsif ($char[$i] eq '\U') {
5082 0           $char[$i] = '@{[Char::Elatin9::uc qq<';
5083 0           $left_e++;
5084             }
5085             elsif ($char[$i] eq '\L') {
5086 0           $char[$i] = '@{[Char::Elatin9::lc qq<';
5087 0           $left_e++;
5088             }
5089             elsif ($char[$i] eq '\F') {
5090 0           $char[$i] = '@{[Char::Elatin9::fc qq<';
5091 0           $left_e++;
5092             }
5093             elsif ($char[$i] eq '\Q') {
5094 0           $char[$i] = '@{[CORE::quotemeta qq<';
5095 0           $left_e++;
5096             }
5097             elsif ($char[$i] eq '\E') {
5098 0 0         if ($right_e < $left_e) {
5099 0           $char[$i] = '>]}';
5100 0           $right_e++;
5101             }
5102             else {
5103 0           $char[$i] = '';
5104             }
5105             }
5106             elsif ($char[$i] eq '\Q') {
5107 0           while (1) {
5108 0 0         if (++$i > $#char) {
5109 0           last;
5110             }
5111 0 0         if ($char[$i] eq '\E') {
5112 0           last;
5113             }
5114             }
5115             }
5116             elsif ($char[$i] eq '\E') {
5117             }
5118              
5119             # $0 --> $0
5120             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5121             }
5122             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5123             }
5124              
5125             # $$ --> $$
5126             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5127             }
5128              
5129             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5130             # $1, $2, $3 --> $1, $2, $3 otherwise
5131             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5132 0           $char[$i] = e_capture($1);
5133             }
5134             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5135 0           $char[$i] = e_capture($1);
5136             }
5137              
5138             # $$foo[ ... ] --> $ $foo->[ ... ]
5139             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5140 0           $char[$i] = e_capture($1.'->'.$2);
5141             }
5142              
5143             # $$foo{ ... } --> $ $foo->{ ... }
5144             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5145 0           $char[$i] = e_capture($1.'->'.$2);
5146             }
5147              
5148             # $$foo
5149             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5150 0           $char[$i] = e_capture($1);
5151             }
5152              
5153             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin9::PREMATCH()
5154             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5155 0           $char[$i] = '@{[Char::Elatin9::PREMATCH()]}';
5156             }
5157              
5158             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin9::MATCH()
5159             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5160 0           $char[$i] = '@{[Char::Elatin9::MATCH()]}';
5161             }
5162              
5163             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin9::POSTMATCH()
5164             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5165 0           $char[$i] = '@{[Char::Elatin9::POSTMATCH()]}';
5166             }
5167              
5168             # ${ foo } --> ${ foo }
5169             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5170             }
5171              
5172             # ${ ... }
5173             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5174 0           $char[$i] = e_capture($1);
5175             }
5176             }
5177              
5178             # return string
5179 0 0         if ($left_e > $right_e) {
5180 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5181             }
5182 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5183             }
5184              
5185             #
5186             # escape qw string (qw//)
5187             #
5188             sub e_qw {
5189 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5190              
5191 0           $slash = 'div';
5192              
5193             # choice again delimiter
5194 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5195 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5196 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5197             }
5198             elsif (not $octet{')'}) {
5199 0           return join '', $ope, '(', $string, ')';
5200             }
5201             elsif (not $octet{'}'}) {
5202 0           return join '', $ope, '{', $string, '}';
5203             }
5204             elsif (not $octet{']'}) {
5205 0           return join '', $ope, '[', $string, ']';
5206             }
5207             elsif (not $octet{'>'}) {
5208 0           return join '', $ope, '<', $string, '>';
5209             }
5210             else {
5211 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5212 0 0         if (not $octet{$char}) {
5213 0           return join '', $ope, $char, $string, $char;
5214             }
5215             }
5216             }
5217              
5218             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5219 0           my @string = CORE::split(/\s+/, $string);
5220 0           for my $string (@string) {
5221 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5222 0           for my $octet (@octet) {
5223 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5224 0           $octet = '\\' . $1;
5225             }
5226             }
5227 0           $string = join '', @octet;
5228             }
5229 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5230             }
5231              
5232             #
5233             # escape here document (<<"HEREDOC", <
5234             #
5235             sub e_heredoc {
5236 0     0 0   my($string) = @_;
5237              
5238 0           $slash = 'm//';
5239              
5240 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5241              
5242 0           my $left_e = 0;
5243 0           my $right_e = 0;
5244 0           my @char = $string =~ /\G(
5245             \\o\{ [0-7]+ \} |
5246             \\x\{ [0-9A-Fa-f]+ \} |
5247             \\N\{ [^0-9\}][^\}]* \} |
5248             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5249             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5250             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5251             \$ \s* \d+ |
5252             \$ \s* \{ \s* \d+ \s* \} |
5253             \$ \$ (?![\w\{]) |
5254             \$ \s* \$ \s* $qq_variable |
5255             \\?(?:$q_char)
5256             )/oxmsg;
5257              
5258 0           for (my $i=0; $i <= $#char; $i++) {
5259              
5260             # "\L\u" --> "\u\L"
5261 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5262 0           @char[$i,$i+1] = @char[$i+1,$i];
5263             }
5264              
5265             # "\U\l" --> "\l\U"
5266             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5267 0           @char[$i,$i+1] = @char[$i+1,$i];
5268             }
5269              
5270             # octal escape sequence
5271             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5272 0           $char[$i] = Char::Elatin9::octchr($1);
5273             }
5274              
5275             # hexadecimal escape sequence
5276             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5277 0           $char[$i] = Char::Elatin9::hexchr($1);
5278             }
5279              
5280             # \N{CHARNAME} --> N{CHARNAME}
5281             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5282 0           $char[$i] = $1;
5283             }
5284              
5285 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          
5286             }
5287              
5288             # \u \l \U \L \F \Q \E
5289 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5290 0 0         if ($right_e < $left_e) {
5291 0           $char[$i] = '\\' . $char[$i];
5292             }
5293             }
5294             elsif ($char[$i] eq '\u') {
5295 0           $char[$i] = '@{[Char::Elatin9::ucfirst qq<';
5296 0           $left_e++;
5297             }
5298             elsif ($char[$i] eq '\l') {
5299 0           $char[$i] = '@{[Char::Elatin9::lcfirst qq<';
5300 0           $left_e++;
5301             }
5302             elsif ($char[$i] eq '\U') {
5303 0           $char[$i] = '@{[Char::Elatin9::uc qq<';
5304 0           $left_e++;
5305             }
5306             elsif ($char[$i] eq '\L') {
5307 0           $char[$i] = '@{[Char::Elatin9::lc qq<';
5308 0           $left_e++;
5309             }
5310             elsif ($char[$i] eq '\F') {
5311 0           $char[$i] = '@{[Char::Elatin9::fc qq<';
5312 0           $left_e++;
5313             }
5314             elsif ($char[$i] eq '\Q') {
5315 0           $char[$i] = '@{[CORE::quotemeta qq<';
5316 0           $left_e++;
5317             }
5318             elsif ($char[$i] eq '\E') {
5319 0 0         if ($right_e < $left_e) {
5320 0           $char[$i] = '>]}';
5321 0           $right_e++;
5322             }
5323             else {
5324 0           $char[$i] = '';
5325             }
5326             }
5327             elsif ($char[$i] eq '\Q') {
5328 0           while (1) {
5329 0 0         if (++$i > $#char) {
5330 0           last;
5331             }
5332 0 0         if ($char[$i] eq '\E') {
5333 0           last;
5334             }
5335             }
5336             }
5337             elsif ($char[$i] eq '\E') {
5338             }
5339              
5340             # $0 --> $0
5341             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5342             }
5343             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5344             }
5345              
5346             # $$ --> $$
5347             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5348             }
5349              
5350             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5351             # $1, $2, $3 --> $1, $2, $3 otherwise
5352             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5353 0           $char[$i] = e_capture($1);
5354             }
5355             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5356 0           $char[$i] = e_capture($1);
5357             }
5358              
5359             # $$foo[ ... ] --> $ $foo->[ ... ]
5360             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5361 0           $char[$i] = e_capture($1.'->'.$2);
5362             }
5363              
5364             # $$foo{ ... } --> $ $foo->{ ... }
5365             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5366 0           $char[$i] = e_capture($1.'->'.$2);
5367             }
5368              
5369             # $$foo
5370             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5371 0           $char[$i] = e_capture($1);
5372             }
5373              
5374             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin9::PREMATCH()
5375             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5376 0           $char[$i] = '@{[Char::Elatin9::PREMATCH()]}';
5377             }
5378              
5379             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin9::MATCH()
5380             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5381 0           $char[$i] = '@{[Char::Elatin9::MATCH()]}';
5382             }
5383              
5384             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin9::POSTMATCH()
5385             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5386 0           $char[$i] = '@{[Char::Elatin9::POSTMATCH()]}';
5387             }
5388              
5389             # ${ foo } --> ${ foo }
5390             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5391             }
5392              
5393             # ${ ... }
5394             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5395 0           $char[$i] = e_capture($1);
5396             }
5397             }
5398              
5399             # return string
5400 0 0         if ($left_e > $right_e) {
5401 0           return join '', @char, '>]}' x ($left_e - $right_e);
5402             }
5403 0           return join '', @char;
5404             }
5405              
5406             #
5407             # escape regexp (m//, qr//)
5408             #
5409             sub e_qr {
5410 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5411 0   0       $modifier ||= '';
5412              
5413 0           $modifier =~ tr/p//d;
5414 0 0         if ($modifier =~ /([adlu])/oxms) {
5415 0           my $line = 0;
5416 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5417 0 0         if ($filename ne __FILE__) {
5418 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5419 0           last;
5420             }
5421             }
5422 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5423             }
5424              
5425 0           $slash = 'div';
5426              
5427             # literal null string pattern
5428 0 0         if ($string eq '') {
    0          
5429 0           $modifier =~ tr/bB//d;
5430 0           $modifier =~ tr/i//d;
5431 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5432             }
5433              
5434             # /b /B modifier
5435             elsif ($modifier =~ tr/bB//d) {
5436              
5437             # choice again delimiter
5438 0 0         if ($delimiter =~ / [\@:] /oxms) {
5439 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5440 0           my %octet = map {$_ => 1} @char;
  0            
5441 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5442 0           $delimiter = '(';
5443 0           $end_delimiter = ')';
5444             }
5445             elsif (not $octet{'}'}) {
5446 0           $delimiter = '{';
5447 0           $end_delimiter = '}';
5448             }
5449             elsif (not $octet{']'}) {
5450 0           $delimiter = '[';
5451 0           $end_delimiter = ']';
5452             }
5453             elsif (not $octet{'>'}) {
5454 0           $delimiter = '<';
5455 0           $end_delimiter = '>';
5456             }
5457             else {
5458 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5459 0 0         if (not $octet{$char}) {
5460 0           $delimiter = $char;
5461 0           $end_delimiter = $char;
5462 0           last;
5463             }
5464             }
5465             }
5466             }
5467              
5468 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5469 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5470             }
5471             else {
5472 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5473             }
5474             }
5475              
5476 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5477 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5478              
5479             # split regexp
5480 0           my @char = $string =~ /\G(
5481             \\o\{ [0-7]+ \} |
5482             \\ [0-7]{2,3} |
5483             \\x\{ [0-9A-Fa-f]+ \} |
5484             \\x [0-9A-Fa-f]{1,2} |
5485             \\c [\x40-\x5F] |
5486             \\N\{ [^0-9\}][^\}]* \} |
5487             \\p\{ [^0-9\}][^\}]* \} |
5488             \\P\{ [^0-9\}][^\}]* \} |
5489             \\ (?:$q_char) |
5490             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5491             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5492             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5493             [\$\@] $qq_variable |
5494             \$ \s* \d+ |
5495             \$ \s* \{ \s* \d+ \s* \} |
5496             \$ \$ (?![\w\{]) |
5497             \$ \s* \$ \s* $qq_variable |
5498             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5499             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5500             \[\^ |
5501             \(\? |
5502             (?:$q_char)
5503             )/oxmsg;
5504              
5505             # choice again delimiter
5506 0 0         if ($delimiter =~ / [\@:] /oxms) {
5507 0           my %octet = map {$_ => 1} @char;
  0            
5508 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5509 0           $delimiter = '(';
5510 0           $end_delimiter = ')';
5511             }
5512             elsif (not $octet{'}'}) {
5513 0           $delimiter = '{';
5514 0           $end_delimiter = '}';
5515             }
5516             elsif (not $octet{']'}) {
5517 0           $delimiter = '[';
5518 0           $end_delimiter = ']';
5519             }
5520             elsif (not $octet{'>'}) {
5521 0           $delimiter = '<';
5522 0           $end_delimiter = '>';
5523             }
5524             else {
5525 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5526 0 0         if (not $octet{$char}) {
5527 0           $delimiter = $char;
5528 0           $end_delimiter = $char;
5529 0           last;
5530             }
5531             }
5532             }
5533             }
5534              
5535 0           my $left_e = 0;
5536 0           my $right_e = 0;
5537 0           for (my $i=0; $i <= $#char; $i++) {
5538              
5539             # "\L\u" --> "\u\L"
5540 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
5541 0           @char[$i,$i+1] = @char[$i+1,$i];
5542             }
5543              
5544             # "\U\l" --> "\l\U"
5545             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5546 0           @char[$i,$i+1] = @char[$i+1,$i];
5547             }
5548              
5549             # octal escape sequence
5550             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5551 0           $char[$i] = Char::Elatin9::octchr($1);
5552             }
5553              
5554             # hexadecimal escape sequence
5555             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5556 0           $char[$i] = Char::Elatin9::hexchr($1);
5557             }
5558              
5559             # \N{CHARNAME} --> N\{CHARNAME}
5560             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5561 0           $char[$i] = $1 . '\\' . $2;
5562             }
5563              
5564             # \p{PROPERTY} --> p\{PROPERTY}
5565             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5566 0           $char[$i] = $1 . '\\' . $2;
5567             }
5568              
5569             # \P{PROPERTY} --> P\{PROPERTY}
5570             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5571 0           $char[$i] = $1 . '\\' . $2;
5572             }
5573              
5574             # \p, \P, \X --> p, P, X
5575             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5576 0           $char[$i] = $1;
5577             }
5578              
5579 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          
5580             }
5581              
5582             # join separated multiple-octet
5583 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5584 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        
5585 0           $char[$i] .= join '', splice @char, $i+1, 3;
5586             }
5587             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)) {
5588 0           $char[$i] .= join '', splice @char, $i+1, 2;
5589             }
5590             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)) {
5591 0           $char[$i] .= join '', splice @char, $i+1, 1;
5592             }
5593             }
5594              
5595             # open character class [...]
5596             elsif ($char[$i] eq '[') {
5597 0           my $left = $i;
5598              
5599             # [] make die "Unmatched [] in regexp ..."
5600             # (and so on)
5601              
5602 0 0         if ($char[$i+1] eq ']') {
5603 0           $i++;
5604             }
5605              
5606 0           while (1) {
5607 0 0         if (++$i > $#char) {
5608 0           die __FILE__, ": Unmatched [] in regexp";
5609             }
5610 0 0         if ($char[$i] eq ']') {
5611 0           my $right = $i;
5612              
5613             # [...]
5614 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5615 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin9::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5616             }
5617             else {
5618 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
5619             }
5620              
5621 0           $i = $left;
5622 0           last;
5623             }
5624             }
5625             }
5626              
5627             # open character class [^...]
5628             elsif ($char[$i] eq '[^') {
5629 0           my $left = $i;
5630              
5631             # [^] make die "Unmatched [] in regexp ..."
5632             # (and so on)
5633              
5634 0 0         if ($char[$i+1] eq ']') {
5635 0           $i++;
5636             }
5637              
5638 0           while (1) {
5639 0 0         if (++$i > $#char) {
5640 0           die __FILE__, ": Unmatched [] in regexp";
5641             }
5642 0 0         if ($char[$i] eq ']') {
5643 0           my $right = $i;
5644              
5645             # [^...]
5646 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5647 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin9::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5648             }
5649             else {
5650 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5651             }
5652              
5653 0           $i = $left;
5654 0           last;
5655             }
5656             }
5657             }
5658              
5659             # rewrite character class or escape character
5660             elsif (my $char = character_class($char[$i],$modifier)) {
5661 0           $char[$i] = $char;
5662             }
5663              
5664             # /i modifier
5665             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin9::uc($char[$i]) ne Char::Elatin9::fc($char[$i]))) {
5666 0 0         if (CORE::length(Char::Elatin9::fc($char[$i])) == 1) {
5667 0           $char[$i] = '[' . Char::Elatin9::uc($char[$i]) . Char::Elatin9::fc($char[$i]) . ']';
5668             }
5669             else {
5670 0           $char[$i] = '(?:' . Char::Elatin9::uc($char[$i]) . '|' . Char::Elatin9::fc($char[$i]) . ')';
5671             }
5672             }
5673              
5674             # \u \l \U \L \F \Q \E
5675             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5676 0 0         if ($right_e < $left_e) {
5677 0           $char[$i] = '\\' . $char[$i];
5678             }
5679             }
5680             elsif ($char[$i] eq '\u') {
5681 0           $char[$i] = '@{[Char::Elatin9::ucfirst qq<';
5682 0           $left_e++;
5683             }
5684             elsif ($char[$i] eq '\l') {
5685 0           $char[$i] = '@{[Char::Elatin9::lcfirst qq<';
5686 0           $left_e++;
5687             }
5688             elsif ($char[$i] eq '\U') {
5689 0           $char[$i] = '@{[Char::Elatin9::uc qq<';
5690 0           $left_e++;
5691             }
5692             elsif ($char[$i] eq '\L') {
5693 0           $char[$i] = '@{[Char::Elatin9::lc qq<';
5694 0           $left_e++;
5695             }
5696             elsif ($char[$i] eq '\F') {
5697 0           $char[$i] = '@{[Char::Elatin9::fc qq<';
5698 0           $left_e++;
5699             }
5700             elsif ($char[$i] eq '\Q') {
5701 0           $char[$i] = '@{[CORE::quotemeta qq<';
5702 0           $left_e++;
5703             }
5704             elsif ($char[$i] eq '\E') {
5705 0 0         if ($right_e < $left_e) {
5706 0           $char[$i] = '>]}';
5707 0           $right_e++;
5708             }
5709             else {
5710 0           $char[$i] = '';
5711             }
5712             }
5713             elsif ($char[$i] eq '\Q') {
5714 0           while (1) {
5715 0 0         if (++$i > $#char) {
5716 0           last;
5717             }
5718 0 0         if ($char[$i] eq '\E') {
5719 0           last;
5720             }
5721             }
5722             }
5723             elsif ($char[$i] eq '\E') {
5724             }
5725              
5726             # $0 --> $0
5727             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5728 0 0         if ($ignorecase) {
5729 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5730             }
5731             }
5732             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5733 0 0         if ($ignorecase) {
5734 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5735             }
5736             }
5737              
5738             # $$ --> $$
5739             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5740             }
5741              
5742             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5743             # $1, $2, $3 --> $1, $2, $3 otherwise
5744             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5745 0           $char[$i] = e_capture($1);
5746 0 0         if ($ignorecase) {
5747 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5748             }
5749             }
5750             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5751 0           $char[$i] = e_capture($1);
5752 0 0         if ($ignorecase) {
5753 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5754             }
5755             }
5756              
5757             # $$foo[ ... ] --> $ $foo->[ ... ]
5758             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5759 0           $char[$i] = e_capture($1.'->'.$2);
5760 0 0         if ($ignorecase) {
5761 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5762             }
5763             }
5764              
5765             # $$foo{ ... } --> $ $foo->{ ... }
5766             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5767 0           $char[$i] = e_capture($1.'->'.$2);
5768 0 0         if ($ignorecase) {
5769 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5770             }
5771             }
5772              
5773             # $$foo
5774             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5775 0           $char[$i] = e_capture($1);
5776 0 0         if ($ignorecase) {
5777 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5778             }
5779             }
5780              
5781             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin9::PREMATCH()
5782             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5783 0 0         if ($ignorecase) {
5784 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::PREMATCH())]}';
5785             }
5786             else {
5787 0           $char[$i] = '@{[Char::Elatin9::PREMATCH()]}';
5788             }
5789             }
5790              
5791             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin9::MATCH()
5792             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5793 0 0         if ($ignorecase) {
5794 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::MATCH())]}';
5795             }
5796             else {
5797 0           $char[$i] = '@{[Char::Elatin9::MATCH()]}';
5798             }
5799             }
5800              
5801             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin9::POSTMATCH()
5802             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5803 0 0         if ($ignorecase) {
5804 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::POSTMATCH())]}';
5805             }
5806             else {
5807 0           $char[$i] = '@{[Char::Elatin9::POSTMATCH()]}';
5808             }
5809             }
5810              
5811             # ${ foo }
5812             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5813 0 0         if ($ignorecase) {
5814 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5815             }
5816             }
5817              
5818             # ${ ... }
5819             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5820 0           $char[$i] = e_capture($1);
5821 0 0         if ($ignorecase) {
5822 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5823             }
5824             }
5825              
5826             # $scalar or @array
5827             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5828 0           $char[$i] = e_string($char[$i]);
5829 0 0         if ($ignorecase) {
5830 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
5831             }
5832             }
5833              
5834             # quote character before ? + * {
5835             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5836 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5837             }
5838             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5839 0           my $char = $char[$i-1];
5840 0 0         if ($char[$i] eq '{') {
5841 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
5842             }
5843             else {
5844 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
5845             }
5846             }
5847             else {
5848 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5849             }
5850             }
5851             }
5852              
5853             # make regexp string
5854 0           $modifier =~ tr/i//d;
5855 0 0         if ($left_e > $right_e) {
5856 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5857 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5858             }
5859             else {
5860 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5861             }
5862             }
5863 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5864 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5865             }
5866             else {
5867 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5868             }
5869             }
5870              
5871             #
5872             # double quote stuff
5873             #
5874             sub qq_stuff {
5875 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5876              
5877             # scalar variable or array variable
5878 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5879 0           return $stuff;
5880             }
5881              
5882             # quote by delimiter
5883 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5884 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5885 0 0         next if $char eq $delimiter;
5886 0 0         next if $char eq $end_delimiter;
5887 0 0         if (not $octet{$char}) {
5888 0           return join '', 'qq', $char, $stuff, $char;
5889             }
5890             }
5891 0           return join '', 'qq', '<', $stuff, '>';
5892             }
5893              
5894             #
5895             # escape regexp (m'', qr'', and m''b, qr''b)
5896             #
5897             sub e_qr_q {
5898 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5899 0   0       $modifier ||= '';
5900              
5901 0           $modifier =~ tr/p//d;
5902 0 0         if ($modifier =~ /([adlu])/oxms) {
5903 0           my $line = 0;
5904 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5905 0 0         if ($filename ne __FILE__) {
5906 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5907 0           last;
5908             }
5909             }
5910 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5911             }
5912              
5913 0           $slash = 'div';
5914              
5915             # literal null string pattern
5916 0 0         if ($string eq '') {
    0          
5917 0           $modifier =~ tr/bB//d;
5918 0           $modifier =~ tr/i//d;
5919 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5920             }
5921              
5922             # with /b /B modifier
5923             elsif ($modifier =~ tr/bB//d) {
5924 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5925             }
5926              
5927             # without /b /B modifier
5928             else {
5929 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5930             }
5931             }
5932              
5933             #
5934             # escape regexp (m'', qr'')
5935             #
5936             sub e_qr_qt {
5937 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5938              
5939 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5940              
5941             # split regexp
5942 0           my @char = $string =~ /\G(
5943             \[\:\^ [a-z]+ \:\] |
5944             \[\: [a-z]+ \:\] |
5945             \[\^ |
5946             [\$\@\/\\] |
5947             \\? (?:$q_char)
5948             )/oxmsg;
5949              
5950             # unescape character
5951 0           for (my $i=0; $i <= $#char; $i++) {
5952 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5953             }
5954              
5955             # open character class [...]
5956 0           elsif ($char[$i] eq '[') {
5957 0           my $left = $i;
5958 0 0         if ($char[$i+1] eq ']') {
5959 0           $i++;
5960             }
5961 0           while (1) {
5962 0 0         if (++$i > $#char) {
5963 0           die __FILE__, ": Unmatched [] in regexp";
5964             }
5965 0 0         if ($char[$i] eq ']') {
5966 0           my $right = $i;
5967              
5968             # [...]
5969 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
5970              
5971 0           $i = $left;
5972 0           last;
5973             }
5974             }
5975             }
5976              
5977             # open character class [^...]
5978             elsif ($char[$i] eq '[^') {
5979 0           my $left = $i;
5980 0 0         if ($char[$i+1] eq ']') {
5981 0           $i++;
5982             }
5983 0           while (1) {
5984 0 0         if (++$i > $#char) {
5985 0           die __FILE__, ": Unmatched [] in regexp";
5986             }
5987 0 0         if ($char[$i] eq ']') {
5988 0           my $right = $i;
5989              
5990             # [^...]
5991 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5992              
5993 0           $i = $left;
5994 0           last;
5995             }
5996             }
5997             }
5998              
5999             # escape $ @ / and \
6000             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6001 0           $char[$i] = '\\' . $char[$i];
6002             }
6003              
6004             # rewrite character class or escape character
6005             elsif (my $char = character_class($char[$i],$modifier)) {
6006 0           $char[$i] = $char;
6007             }
6008              
6009             # /i modifier
6010             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin9::uc($char[$i]) ne Char::Elatin9::fc($char[$i]))) {
6011 0 0         if (CORE::length(Char::Elatin9::fc($char[$i])) == 1) {
6012 0           $char[$i] = '[' . Char::Elatin9::uc($char[$i]) . Char::Elatin9::fc($char[$i]) . ']';
6013             }
6014             else {
6015 0           $char[$i] = '(?:' . Char::Elatin9::uc($char[$i]) . '|' . Char::Elatin9::fc($char[$i]) . ')';
6016             }
6017             }
6018              
6019             # quote character before ? + * {
6020             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6021 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6022             }
6023             else {
6024 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6025             }
6026             }
6027             }
6028              
6029 0           $delimiter = '/';
6030 0           $end_delimiter = '/';
6031              
6032 0           $modifier =~ tr/i//d;
6033 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6034             }
6035              
6036             #
6037             # escape regexp (m''b, qr''b)
6038             #
6039             sub e_qr_qb {
6040 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6041              
6042             # split regexp
6043 0           my @char = $string =~ /\G(
6044             \\\\ |
6045             [\$\@\/\\] |
6046             [\x00-\xFF]
6047             )/oxmsg;
6048              
6049             # unescape character
6050 0           for (my $i=0; $i <= $#char; $i++) {
6051 0 0         if (0) {
    0          
6052             }
6053              
6054             # remain \\
6055 0           elsif ($char[$i] eq '\\\\') {
6056             }
6057              
6058             # escape $ @ / and \
6059             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6060 0           $char[$i] = '\\' . $char[$i];
6061             }
6062             }
6063              
6064 0           $delimiter = '/';
6065 0           $end_delimiter = '/';
6066 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6067             }
6068              
6069             #
6070             # escape regexp (s/here//)
6071             #
6072             sub e_s1 {
6073 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6074 0   0       $modifier ||= '';
6075              
6076 0           $modifier =~ tr/p//d;
6077 0 0         if ($modifier =~ /([adlu])/oxms) {
6078 0           my $line = 0;
6079 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6080 0 0         if ($filename ne __FILE__) {
6081 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6082 0           last;
6083             }
6084             }
6085 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6086             }
6087              
6088 0           $slash = 'div';
6089              
6090             # literal null string pattern
6091 0 0         if ($string eq '') {
    0          
6092 0           $modifier =~ tr/bB//d;
6093 0           $modifier =~ tr/i//d;
6094 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6095             }
6096              
6097             # /b /B modifier
6098             elsif ($modifier =~ tr/bB//d) {
6099              
6100             # choice again delimiter
6101 0 0         if ($delimiter =~ / [\@:] /oxms) {
6102 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
6103 0           my %octet = map {$_ => 1} @char;
  0            
6104 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6105 0           $delimiter = '(';
6106 0           $end_delimiter = ')';
6107             }
6108             elsif (not $octet{'}'}) {
6109 0           $delimiter = '{';
6110 0           $end_delimiter = '}';
6111             }
6112             elsif (not $octet{']'}) {
6113 0           $delimiter = '[';
6114 0           $end_delimiter = ']';
6115             }
6116             elsif (not $octet{'>'}) {
6117 0           $delimiter = '<';
6118 0           $end_delimiter = '>';
6119             }
6120             else {
6121 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6122 0 0         if (not $octet{$char}) {
6123 0           $delimiter = $char;
6124 0           $end_delimiter = $char;
6125 0           last;
6126             }
6127             }
6128             }
6129             }
6130              
6131 0           my $prematch = '';
6132 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6133             }
6134              
6135 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6136 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6137              
6138             # split regexp
6139 0           my @char = $string =~ /\G(
6140             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
6141             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
6142             \\g \s* [1-9][0-9]* |
6143             \\o\{ [0-7]+ \} |
6144             \\ [1-9][0-9]* |
6145             \\ [0-7]{2,3} |
6146             \\x\{ [0-9A-Fa-f]+ \} |
6147             \\x [0-9A-Fa-f]{1,2} |
6148             \\c [\x40-\x5F] |
6149             \\N\{ [^0-9\}][^\}]* \} |
6150             \\p\{ [^0-9\}][^\}]* \} |
6151             \\P\{ [^0-9\}][^\}]* \} |
6152             \\ (?:$q_char) |
6153             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6154             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6155             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6156             [\$\@] $qq_variable |
6157             \$ \s* \d+ |
6158             \$ \s* \{ \s* \d+ \s* \} |
6159             \$ \$ (?![\w\{]) |
6160             \$ \s* \$ \s* $qq_variable |
6161             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6162             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6163             \[\^ |
6164             \(\? |
6165             (?:$q_char)
6166             )/oxmsg;
6167              
6168             # choice again delimiter
6169 0 0         if ($delimiter =~ / [\@:] /oxms) {
6170 0           my %octet = map {$_ => 1} @char;
  0            
6171 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6172 0           $delimiter = '(';
6173 0           $end_delimiter = ')';
6174             }
6175             elsif (not $octet{'}'}) {
6176 0           $delimiter = '{';
6177 0           $end_delimiter = '}';
6178             }
6179             elsif (not $octet{']'}) {
6180 0           $delimiter = '[';
6181 0           $end_delimiter = ']';
6182             }
6183             elsif (not $octet{'>'}) {
6184 0           $delimiter = '<';
6185 0           $end_delimiter = '>';
6186             }
6187             else {
6188 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6189 0 0         if (not $octet{$char}) {
6190 0           $delimiter = $char;
6191 0           $end_delimiter = $char;
6192 0           last;
6193             }
6194             }
6195             }
6196             }
6197              
6198             # count '('
6199 0           my $parens = grep { $_ eq '(' } @char;
  0            
6200              
6201 0           my $left_e = 0;
6202 0           my $right_e = 0;
6203 0           for (my $i=0; $i <= $#char; $i++) {
6204              
6205             # "\L\u" --> "\u\L"
6206 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6207 0           @char[$i,$i+1] = @char[$i+1,$i];
6208             }
6209              
6210             # "\U\l" --> "\l\U"
6211             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6212 0           @char[$i,$i+1] = @char[$i+1,$i];
6213             }
6214              
6215             # octal escape sequence
6216             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6217 0           $char[$i] = Char::Elatin9::octchr($1);
6218             }
6219              
6220             # hexadecimal escape sequence
6221             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6222 0           $char[$i] = Char::Elatin9::hexchr($1);
6223             }
6224              
6225             # \N{CHARNAME} --> N\{CHARNAME}
6226             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6227 0           $char[$i] = $1 . '\\' . $2;
6228             }
6229              
6230             # \p{PROPERTY} --> p\{PROPERTY}
6231             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6232 0           $char[$i] = $1 . '\\' . $2;
6233             }
6234              
6235             # \P{PROPERTY} --> P\{PROPERTY}
6236             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6237 0           $char[$i] = $1 . '\\' . $2;
6238             }
6239              
6240             # \p, \P, \X --> p, P, X
6241             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6242 0           $char[$i] = $1;
6243             }
6244              
6245 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          
6246             }
6247              
6248             # join separated multiple-octet
6249 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6250 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        
6251 0           $char[$i] .= join '', splice @char, $i+1, 3;
6252             }
6253             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)) {
6254 0           $char[$i] .= join '', splice @char, $i+1, 2;
6255             }
6256             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)) {
6257 0           $char[$i] .= join '', splice @char, $i+1, 1;
6258             }
6259             }
6260              
6261             # open character class [...]
6262             elsif ($char[$i] eq '[') {
6263 0           my $left = $i;
6264 0 0         if ($char[$i+1] eq ']') {
6265 0           $i++;
6266             }
6267 0           while (1) {
6268 0 0         if (++$i > $#char) {
6269 0           die __FILE__, ": Unmatched [] in regexp";
6270             }
6271 0 0         if ($char[$i] eq ']') {
6272 0           my $right = $i;
6273              
6274             # [...]
6275 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6276 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin9::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6277             }
6278             else {
6279 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
6280             }
6281              
6282 0           $i = $left;
6283 0           last;
6284             }
6285             }
6286             }
6287              
6288             # open character class [^...]
6289             elsif ($char[$i] eq '[^') {
6290 0           my $left = $i;
6291 0 0         if ($char[$i+1] eq ']') {
6292 0           $i++;
6293             }
6294 0           while (1) {
6295 0 0         if (++$i > $#char) {
6296 0           die __FILE__, ": Unmatched [] in regexp";
6297             }
6298 0 0         if ($char[$i] eq ']') {
6299 0           my $right = $i;
6300              
6301             # [^...]
6302 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6303 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin9::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6304             }
6305             else {
6306 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6307             }
6308              
6309 0           $i = $left;
6310 0           last;
6311             }
6312             }
6313             }
6314              
6315             # rewrite character class or escape character
6316             elsif (my $char = character_class($char[$i],$modifier)) {
6317 0           $char[$i] = $char;
6318             }
6319              
6320             # /i modifier
6321             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin9::uc($char[$i]) ne Char::Elatin9::fc($char[$i]))) {
6322 0 0         if (CORE::length(Char::Elatin9::fc($char[$i])) == 1) {
6323 0           $char[$i] = '[' . Char::Elatin9::uc($char[$i]) . Char::Elatin9::fc($char[$i]) . ']';
6324             }
6325             else {
6326 0           $char[$i] = '(?:' . Char::Elatin9::uc($char[$i]) . '|' . Char::Elatin9::fc($char[$i]) . ')';
6327             }
6328             }
6329              
6330             # \u \l \U \L \F \Q \E
6331             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6332 0 0         if ($right_e < $left_e) {
6333 0           $char[$i] = '\\' . $char[$i];
6334             }
6335             }
6336             elsif ($char[$i] eq '\u') {
6337 0           $char[$i] = '@{[Char::Elatin9::ucfirst qq<';
6338 0           $left_e++;
6339             }
6340             elsif ($char[$i] eq '\l') {
6341 0           $char[$i] = '@{[Char::Elatin9::lcfirst qq<';
6342 0           $left_e++;
6343             }
6344             elsif ($char[$i] eq '\U') {
6345 0           $char[$i] = '@{[Char::Elatin9::uc qq<';
6346 0           $left_e++;
6347             }
6348             elsif ($char[$i] eq '\L') {
6349 0           $char[$i] = '@{[Char::Elatin9::lc qq<';
6350 0           $left_e++;
6351             }
6352             elsif ($char[$i] eq '\F') {
6353 0           $char[$i] = '@{[Char::Elatin9::fc qq<';
6354 0           $left_e++;
6355             }
6356             elsif ($char[$i] eq '\Q') {
6357 0           $char[$i] = '@{[CORE::quotemeta qq<';
6358 0           $left_e++;
6359             }
6360             elsif ($char[$i] eq '\E') {
6361 0 0         if ($right_e < $left_e) {
6362 0           $char[$i] = '>]}';
6363 0           $right_e++;
6364             }
6365             else {
6366 0           $char[$i] = '';
6367             }
6368             }
6369             elsif ($char[$i] eq '\Q') {
6370 0           while (1) {
6371 0 0         if (++$i > $#char) {
6372 0           last;
6373             }
6374 0 0         if ($char[$i] eq '\E') {
6375 0           last;
6376             }
6377             }
6378             }
6379             elsif ($char[$i] eq '\E') {
6380             }
6381              
6382             # \0 --> \0
6383             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
6384             }
6385              
6386             # \g{N}, \g{-N}
6387              
6388             # P.108 Using Simple Patterns
6389             # in Chapter 7: In the World of Regular Expressions
6390             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6391              
6392             # P.221 Capturing
6393             # in Chapter 5: Pattern Matching
6394             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6395              
6396             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6397             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6398             }
6399              
6400             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6401             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6402             }
6403              
6404             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6405             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
6406             }
6407              
6408             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6409             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
6410             }
6411              
6412             # $0 --> $0
6413             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6414 0 0         if ($ignorecase) {
6415 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6416             }
6417             }
6418             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
6419 0 0         if ($ignorecase) {
6420 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6421             }
6422             }
6423              
6424             # $$ --> $$
6425             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6426             }
6427              
6428             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6429             # $1, $2, $3 --> $1, $2, $3 otherwise
6430             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
6431 0           $char[$i] = e_capture($1);
6432 0 0         if ($ignorecase) {
6433 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6434             }
6435             }
6436             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6437 0           $char[$i] = e_capture($1);
6438 0 0         if ($ignorecase) {
6439 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6440             }
6441             }
6442              
6443             # $$foo[ ... ] --> $ $foo->[ ... ]
6444             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6445 0           $char[$i] = e_capture($1.'->'.$2);
6446 0 0         if ($ignorecase) {
6447 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6448             }
6449             }
6450              
6451             # $$foo{ ... } --> $ $foo->{ ... }
6452             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6453 0           $char[$i] = e_capture($1.'->'.$2);
6454 0 0         if ($ignorecase) {
6455 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6456             }
6457             }
6458              
6459             # $$foo
6460             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
6461 0           $char[$i] = e_capture($1);
6462 0 0         if ($ignorecase) {
6463 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6464             }
6465             }
6466              
6467             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin9::PREMATCH()
6468             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
6469 0 0         if ($ignorecase) {
6470 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::PREMATCH())]}';
6471             }
6472             else {
6473 0           $char[$i] = '@{[Char::Elatin9::PREMATCH()]}';
6474             }
6475             }
6476              
6477             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin9::MATCH()
6478             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
6479 0 0         if ($ignorecase) {
6480 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::MATCH())]}';
6481             }
6482             else {
6483 0           $char[$i] = '@{[Char::Elatin9::MATCH()]}';
6484             }
6485             }
6486              
6487             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin9::POSTMATCH()
6488             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
6489 0 0         if ($ignorecase) {
6490 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::POSTMATCH())]}';
6491             }
6492             else {
6493 0           $char[$i] = '@{[Char::Elatin9::POSTMATCH()]}';
6494             }
6495             }
6496              
6497             # ${ foo }
6498             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
6499 0 0         if ($ignorecase) {
6500 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6501             }
6502             }
6503              
6504             # ${ ... }
6505             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
6506 0           $char[$i] = e_capture($1);
6507 0 0         if ($ignorecase) {
6508 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6509             }
6510             }
6511              
6512             # $scalar or @array
6513             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6514 0           $char[$i] = e_string($char[$i]);
6515 0 0         if ($ignorecase) {
6516 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
6517             }
6518             }
6519              
6520             # quote character before ? + * {
6521             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6522 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6523             }
6524             else {
6525 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6526             }
6527             }
6528             }
6529              
6530             # make regexp string
6531 0           my $prematch = '';
6532 0           $modifier =~ tr/i//d;
6533 0 0         if ($left_e > $right_e) {
6534 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6535             }
6536 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6537             }
6538              
6539             #
6540             # escape regexp (s'here'' or s'here''b)
6541             #
6542             sub e_s1_q {
6543 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6544 0   0       $modifier ||= '';
6545              
6546 0           $modifier =~ tr/p//d;
6547 0 0         if ($modifier =~ /([adlu])/oxms) {
6548 0           my $line = 0;
6549 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6550 0 0         if ($filename ne __FILE__) {
6551 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6552 0           last;
6553             }
6554             }
6555 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6556             }
6557              
6558 0           $slash = 'div';
6559              
6560             # literal null string pattern
6561 0 0         if ($string eq '') {
    0          
6562 0           $modifier =~ tr/bB//d;
6563 0           $modifier =~ tr/i//d;
6564 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6565             }
6566              
6567             # with /b /B modifier
6568             elsif ($modifier =~ tr/bB//d) {
6569 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6570             }
6571              
6572             # without /b /B modifier
6573             else {
6574 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6575             }
6576             }
6577              
6578             #
6579             # escape regexp (s'here'')
6580             #
6581             sub e_s1_qt {
6582 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6583              
6584 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6585              
6586             # split regexp
6587 0           my @char = $string =~ /\G(
6588             \[\:\^ [a-z]+ \:\] |
6589             \[\: [a-z]+ \:\] |
6590             \[\^ |
6591             [\$\@\/\\] |
6592             \\? (?:$q_char)
6593             )/oxmsg;
6594              
6595             # unescape character
6596 0           for (my $i=0; $i <= $#char; $i++) {
6597 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6598             }
6599              
6600             # open character class [...]
6601 0           elsif ($char[$i] eq '[') {
6602 0           my $left = $i;
6603 0 0         if ($char[$i+1] eq ']') {
6604 0           $i++;
6605             }
6606 0           while (1) {
6607 0 0         if (++$i > $#char) {
6608 0           die __FILE__, ": Unmatched [] in regexp";
6609             }
6610 0 0         if ($char[$i] eq ']') {
6611 0           my $right = $i;
6612              
6613             # [...]
6614 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
6615              
6616 0           $i = $left;
6617 0           last;
6618             }
6619             }
6620             }
6621              
6622             # open character class [^...]
6623             elsif ($char[$i] eq '[^') {
6624 0           my $left = $i;
6625 0 0         if ($char[$i+1] eq ']') {
6626 0           $i++;
6627             }
6628 0           while (1) {
6629 0 0         if (++$i > $#char) {
6630 0           die __FILE__, ": Unmatched [] in regexp";
6631             }
6632 0 0         if ($char[$i] eq ']') {
6633 0           my $right = $i;
6634              
6635             # [^...]
6636 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6637              
6638 0           $i = $left;
6639 0           last;
6640             }
6641             }
6642             }
6643              
6644             # escape $ @ / and \
6645             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6646 0           $char[$i] = '\\' . $char[$i];
6647             }
6648              
6649             # rewrite character class or escape character
6650             elsif (my $char = character_class($char[$i],$modifier)) {
6651 0           $char[$i] = $char;
6652             }
6653              
6654             # /i modifier
6655             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin9::uc($char[$i]) ne Char::Elatin9::fc($char[$i]))) {
6656 0 0         if (CORE::length(Char::Elatin9::fc($char[$i])) == 1) {
6657 0           $char[$i] = '[' . Char::Elatin9::uc($char[$i]) . Char::Elatin9::fc($char[$i]) . ']';
6658             }
6659             else {
6660 0           $char[$i] = '(?:' . Char::Elatin9::uc($char[$i]) . '|' . Char::Elatin9::fc($char[$i]) . ')';
6661             }
6662             }
6663              
6664             # quote character before ? + * {
6665             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6666 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6667             }
6668             else {
6669 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6670             }
6671             }
6672             }
6673              
6674 0           $modifier =~ tr/i//d;
6675 0           $delimiter = '/';
6676 0           $end_delimiter = '/';
6677 0           my $prematch = '';
6678 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6679             }
6680              
6681             #
6682             # escape regexp (s'here''b)
6683             #
6684             sub e_s1_qb {
6685 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6686              
6687             # split regexp
6688 0           my @char = $string =~ /\G(
6689             \\\\ |
6690             [\$\@\/\\] |
6691             [\x00-\xFF]
6692             )/oxmsg;
6693              
6694             # unescape character
6695 0           for (my $i=0; $i <= $#char; $i++) {
6696 0 0         if (0) {
    0          
6697             }
6698              
6699             # remain \\
6700 0           elsif ($char[$i] eq '\\\\') {
6701             }
6702              
6703             # escape $ @ / and \
6704             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6705 0           $char[$i] = '\\' . $char[$i];
6706             }
6707             }
6708              
6709 0           $delimiter = '/';
6710 0           $end_delimiter = '/';
6711 0           my $prematch = '';
6712 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6713             }
6714              
6715             #
6716             # escape regexp (s''here')
6717             #
6718             sub e_s2_q {
6719 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6720              
6721 0           $slash = 'div';
6722              
6723 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
6724 0           for (my $i=0; $i <= $#char; $i++) {
6725 0 0         if (0) {
    0          
6726             }
6727              
6728             # not escape \\
6729 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6730             }
6731              
6732             # escape $ @ / and \
6733             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6734 0           $char[$i] = '\\' . $char[$i];
6735             }
6736             }
6737              
6738 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6739             }
6740              
6741             #
6742             # escape regexp (s/here/and here/modifier)
6743             #
6744             sub e_sub {
6745 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6746 0   0       $modifier ||= '';
6747              
6748 0           $modifier =~ tr/p//d;
6749 0 0         if ($modifier =~ /([adlu])/oxms) {
6750 0           my $line = 0;
6751 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6752 0 0         if ($filename ne __FILE__) {
6753 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6754 0           last;
6755             }
6756             }
6757 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6758             }
6759              
6760 0 0         if ($variable eq '') {
6761 0           $variable = '$_';
6762 0           $bind_operator = ' =~ ';
6763             }
6764              
6765 0           $slash = 'div';
6766              
6767             # P.128 Start of match (or end of previous match): \G
6768             # P.130 Advanced Use of \G with Perl
6769             # in Chapter 3: Overview of Regular Expression Features and Flavors
6770             # P.312 Iterative Matching: Scalar Context, with /g
6771             # in Chapter 7: Perl
6772             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6773              
6774             # P.181 Where You Left Off: The \G Assertion
6775             # in Chapter 5: Pattern Matching
6776             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6777              
6778             # P.220 Where You Left Off: The \G Assertion
6779             # in Chapter 5: Pattern Matching
6780             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6781              
6782 0           my $e_modifier = $modifier =~ tr/e//d;
6783 0           my $r_modifier = $modifier =~ tr/r//d;
6784              
6785 0           my $my = '';
6786 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
6787 0           $my = $variable;
6788 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
6789 0           $variable =~ s/ = .+ \z//oxms;
6790             }
6791              
6792 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6793 0           $variable_basename =~ s/ \s+ \z//oxms;
6794              
6795             # quote replacement string
6796 0           my $e_replacement = '';
6797 0 0         if ($e_modifier >= 1) {
6798 0           $e_replacement = e_qq('', '', '', $replacement);
6799 0           $e_modifier--;
6800             }
6801             else {
6802 0 0         if ($delimiter2 eq "'") {
6803 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6804             }
6805             else {
6806 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6807             }
6808             }
6809              
6810 0           my $sub = '';
6811              
6812             # with /r
6813 0 0         if ($r_modifier) {
6814 0 0         if (0) {
6815             }
6816              
6817             # s///gr without multibyte anchoring
6818 0           elsif ($modifier =~ /g/oxms) {
6819 0 0         $sub = sprintf(
6820             # 1 2 3 4 5
6821             q,
6822              
6823             $variable, # 1
6824             ($delimiter1 eq "'") ? # 2
6825             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6826             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6827             $s_matched, # 3
6828             $e_replacement, # 4
6829             '$Char::Latin9::re_r=CORE::eval $Char::Latin9::re_r; ' x $e_modifier, # 5
6830             );
6831             }
6832              
6833             # s///r
6834             else {
6835              
6836 0           my $prematch = q{$`};
6837              
6838 0 0         $sub = sprintf(
6839             # 1 2 3 4 5 6 7
6840             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Char::Latin9::re_r=%s; %s"%s$Char::Latin9::re_r$'" } : %s>,
6841              
6842             $variable, # 1
6843             ($delimiter1 eq "'") ? # 2
6844             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6845             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6846             $s_matched, # 3
6847             $e_replacement, # 4
6848             '$Char::Latin9::re_r=CORE::eval $Char::Latin9::re_r; ' x $e_modifier, # 5
6849             $prematch, # 6
6850             $variable, # 7
6851             );
6852             }
6853              
6854             # $var !~ s///r doesn't make sense
6855 0 0         if ($bind_operator =~ / !~ /oxms) {
6856 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6857             }
6858             }
6859              
6860             # without /r
6861             else {
6862 0 0         if (0) {
6863             }
6864              
6865             # s///g without multibyte anchoring
6866 0           elsif ($modifier =~ /g/oxms) {
6867 0 0         $sub = sprintf(
    0          
6868             # 1 2 3 4 5 6 7 8
6869             q,
6870              
6871             $variable, # 1
6872             ($delimiter1 eq "'") ? # 2
6873             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6874             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6875             $s_matched, # 3
6876             $e_replacement, # 4
6877             '$Char::Latin9::re_r=CORE::eval $Char::Latin9::re_r; ' x $e_modifier, # 5
6878             $variable, # 6
6879             $variable, # 7
6880             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6881             );
6882             }
6883              
6884             # s///
6885             else {
6886              
6887 0           my $prematch = q{$`};
6888              
6889 0 0         $sub = sprintf(
    0          
6890              
6891             ($bind_operator =~ / =~ /oxms) ?
6892              
6893             # 1 2 3 4 5 6 7 8
6894             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Char::Latin9::re_r=%s; %s%s="%s$Char::Latin9::re_r$'"; 1 } : undef> :
6895              
6896             # 1 2 3 4 5 6 7 8
6897             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Char::Latin9::re_r=%s; %s%s="%s$Char::Latin9::re_r$'"; undef }>,
6898              
6899             $variable, # 1
6900             $bind_operator, # 2
6901             ($delimiter1 eq "'") ? # 3
6902             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6903             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6904             $s_matched, # 4
6905             $e_replacement, # 5
6906             '$Char::Latin9::re_r=CORE::eval $Char::Latin9::re_r; ' x $e_modifier, # 6
6907             $variable, # 7
6908             $prematch, # 8
6909             );
6910             }
6911             }
6912              
6913             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6914 0 0         if ($my ne '') {
6915 0           $sub = "($my, $sub)[1]";
6916             }
6917              
6918             # clear s/// variable
6919 0           $sub_variable = '';
6920 0           $bind_operator = '';
6921              
6922 0           return $sub;
6923             }
6924              
6925             #
6926             # escape regexp of split qr//
6927             #
6928             sub e_split {
6929 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6930 0   0       $modifier ||= '';
6931              
6932 0           $modifier =~ tr/p//d;
6933 0 0         if ($modifier =~ /([adlu])/oxms) {
6934 0           my $line = 0;
6935 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6936 0 0         if ($filename ne __FILE__) {
6937 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6938 0           last;
6939             }
6940             }
6941 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6942             }
6943              
6944 0           $slash = 'div';
6945              
6946             # /b /B modifier
6947 0 0         if ($modifier =~ tr/bB//d) {
6948 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6949             }
6950              
6951 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6952 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6953              
6954             # split regexp
6955 0           my @char = $string =~ /\G(
6956             \\o\{ [0-7]+ \} |
6957             \\ [0-7]{2,3} |
6958             \\x\{ [0-9A-Fa-f]+ \} |
6959             \\x [0-9A-Fa-f]{1,2} |
6960             \\c [\x40-\x5F] |
6961             \\N\{ [^0-9\}][^\}]* \} |
6962             \\p\{ [^0-9\}][^\}]* \} |
6963             \\P\{ [^0-9\}][^\}]* \} |
6964             \\ (?:$q_char) |
6965             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6966             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6967             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6968             [\$\@] $qq_variable |
6969             \$ \s* \d+ |
6970             \$ \s* \{ \s* \d+ \s* \} |
6971             \$ \$ (?![\w\{]) |
6972             \$ \s* \$ \s* $qq_variable |
6973             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6974             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6975             \[\^ |
6976             \(\? |
6977             (?:$q_char)
6978             )/oxmsg;
6979              
6980 0           my $left_e = 0;
6981 0           my $right_e = 0;
6982 0           for (my $i=0; $i <= $#char; $i++) {
6983              
6984             # "\L\u" --> "\u\L"
6985 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6986 0           @char[$i,$i+1] = @char[$i+1,$i];
6987             }
6988              
6989             # "\U\l" --> "\l\U"
6990             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6991 0           @char[$i,$i+1] = @char[$i+1,$i];
6992             }
6993              
6994             # octal escape sequence
6995             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6996 0           $char[$i] = Char::Elatin9::octchr($1);
6997             }
6998              
6999             # hexadecimal escape sequence
7000             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7001 0           $char[$i] = Char::Elatin9::hexchr($1);
7002             }
7003              
7004             # \N{CHARNAME} --> N\{CHARNAME}
7005             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7006 0           $char[$i] = $1 . '\\' . $2;
7007             }
7008              
7009             # \p{PROPERTY} --> p\{PROPERTY}
7010             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7011 0           $char[$i] = $1 . '\\' . $2;
7012             }
7013              
7014             # \P{PROPERTY} --> P\{PROPERTY}
7015             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7016 0           $char[$i] = $1 . '\\' . $2;
7017             }
7018              
7019             # \p, \P, \X --> p, P, X
7020             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7021 0           $char[$i] = $1;
7022             }
7023              
7024 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          
7025             }
7026              
7027             # join separated multiple-octet
7028 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7029 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        
7030 0           $char[$i] .= join '', splice @char, $i+1, 3;
7031             }
7032             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)) {
7033 0           $char[$i] .= join '', splice @char, $i+1, 2;
7034             }
7035             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)) {
7036 0           $char[$i] .= join '', splice @char, $i+1, 1;
7037             }
7038             }
7039              
7040             # open character class [...]
7041             elsif ($char[$i] eq '[') {
7042 0           my $left = $i;
7043 0 0         if ($char[$i+1] eq ']') {
7044 0           $i++;
7045             }
7046 0           while (1) {
7047 0 0         if (++$i > $#char) {
7048 0           die __FILE__, ": Unmatched [] in regexp";
7049             }
7050 0 0         if ($char[$i] eq ']') {
7051 0           my $right = $i;
7052              
7053             # [...]
7054 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7055 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin9::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7056             }
7057             else {
7058 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
7059             }
7060              
7061 0           $i = $left;
7062 0           last;
7063             }
7064             }
7065             }
7066              
7067             # open character class [^...]
7068             elsif ($char[$i] eq '[^') {
7069 0           my $left = $i;
7070 0 0         if ($char[$i+1] eq ']') {
7071 0           $i++;
7072             }
7073 0           while (1) {
7074 0 0         if (++$i > $#char) {
7075 0           die __FILE__, ": Unmatched [] in regexp";
7076             }
7077 0 0         if ($char[$i] eq ']') {
7078 0           my $right = $i;
7079              
7080             # [^...]
7081 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7082 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin9::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7083             }
7084             else {
7085 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7086             }
7087              
7088 0           $i = $left;
7089 0           last;
7090             }
7091             }
7092             }
7093              
7094             # rewrite character class or escape character
7095             elsif (my $char = character_class($char[$i],$modifier)) {
7096 0           $char[$i] = $char;
7097             }
7098              
7099             # P.794 29.2.161. split
7100             # in Chapter 29: Functions
7101             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7102              
7103             # P.951 split
7104             # in Chapter 27: Functions
7105             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7106              
7107             # said "The //m modifier is assumed when you split on the pattern /^/",
7108             # but perl5.008 is not so. Therefore, this software adds //m.
7109             # (and so on)
7110              
7111             # split(m/^/) --> split(m/^/m)
7112             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7113 0           $modifier .= 'm';
7114             }
7115              
7116             # /i modifier
7117             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin9::uc($char[$i]) ne Char::Elatin9::fc($char[$i]))) {
7118 0 0         if (CORE::length(Char::Elatin9::fc($char[$i])) == 1) {
7119 0           $char[$i] = '[' . Char::Elatin9::uc($char[$i]) . Char::Elatin9::fc($char[$i]) . ']';
7120             }
7121             else {
7122 0           $char[$i] = '(?:' . Char::Elatin9::uc($char[$i]) . '|' . Char::Elatin9::fc($char[$i]) . ')';
7123             }
7124             }
7125              
7126             # \u \l \U \L \F \Q \E
7127             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7128 0 0         if ($right_e < $left_e) {
7129 0           $char[$i] = '\\' . $char[$i];
7130             }
7131             }
7132             elsif ($char[$i] eq '\u') {
7133 0           $char[$i] = '@{[Char::Elatin9::ucfirst qq<';
7134 0           $left_e++;
7135             }
7136             elsif ($char[$i] eq '\l') {
7137 0           $char[$i] = '@{[Char::Elatin9::lcfirst qq<';
7138 0           $left_e++;
7139             }
7140             elsif ($char[$i] eq '\U') {
7141 0           $char[$i] = '@{[Char::Elatin9::uc qq<';
7142 0           $left_e++;
7143             }
7144             elsif ($char[$i] eq '\L') {
7145 0           $char[$i] = '@{[Char::Elatin9::lc qq<';
7146 0           $left_e++;
7147             }
7148             elsif ($char[$i] eq '\F') {
7149 0           $char[$i] = '@{[Char::Elatin9::fc qq<';
7150 0           $left_e++;
7151             }
7152             elsif ($char[$i] eq '\Q') {
7153 0           $char[$i] = '@{[CORE::quotemeta qq<';
7154 0           $left_e++;
7155             }
7156             elsif ($char[$i] eq '\E') {
7157 0 0         if ($right_e < $left_e) {
7158 0           $char[$i] = '>]}';
7159 0           $right_e++;
7160             }
7161             else {
7162 0           $char[$i] = '';
7163             }
7164             }
7165             elsif ($char[$i] eq '\Q') {
7166 0           while (1) {
7167 0 0         if (++$i > $#char) {
7168 0           last;
7169             }
7170 0 0         if ($char[$i] eq '\E') {
7171 0           last;
7172             }
7173             }
7174             }
7175             elsif ($char[$i] eq '\E') {
7176             }
7177              
7178             # $0 --> $0
7179             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7180 0 0         if ($ignorecase) {
7181 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7182             }
7183             }
7184             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
7185 0 0         if ($ignorecase) {
7186 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7187             }
7188             }
7189              
7190             # $$ --> $$
7191             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7192             }
7193              
7194             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7195             # $1, $2, $3 --> $1, $2, $3 otherwise
7196             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
7197 0           $char[$i] = e_capture($1);
7198 0 0         if ($ignorecase) {
7199 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7200             }
7201             }
7202             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
7203 0           $char[$i] = e_capture($1);
7204 0 0         if ($ignorecase) {
7205 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7206             }
7207             }
7208              
7209             # $$foo[ ... ] --> $ $foo->[ ... ]
7210             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7211 0           $char[$i] = e_capture($1.'->'.$2);
7212 0 0         if ($ignorecase) {
7213 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7214             }
7215             }
7216              
7217             # $$foo{ ... } --> $ $foo->{ ... }
7218             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7219 0           $char[$i] = e_capture($1.'->'.$2);
7220 0 0         if ($ignorecase) {
7221 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7222             }
7223             }
7224              
7225             # $$foo
7226             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
7227 0           $char[$i] = e_capture($1);
7228 0 0         if ($ignorecase) {
7229 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7230             }
7231             }
7232              
7233             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin9::PREMATCH()
7234             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
7235 0 0         if ($ignorecase) {
7236 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::PREMATCH())]}';
7237             }
7238             else {
7239 0           $char[$i] = '@{[Char::Elatin9::PREMATCH()]}';
7240             }
7241             }
7242              
7243             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin9::MATCH()
7244             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
7245 0 0         if ($ignorecase) {
7246 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::MATCH())]}';
7247             }
7248             else {
7249 0           $char[$i] = '@{[Char::Elatin9::MATCH()]}';
7250             }
7251             }
7252              
7253             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin9::POSTMATCH()
7254             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
7255 0 0         if ($ignorecase) {
7256 0           $char[$i] = '@{[Char::Elatin9::ignorecase(Char::Elatin9::POSTMATCH())]}';
7257             }
7258             else {
7259 0           $char[$i] = '@{[Char::Elatin9::POSTMATCH()]}';
7260             }
7261             }
7262              
7263             # ${ foo }
7264             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
7265 0 0         if ($ignorecase) {
7266 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $1 . ')]}';
7267             }
7268             }
7269              
7270             # ${ ... }
7271             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
7272 0           $char[$i] = e_capture($1);
7273 0 0         if ($ignorecase) {
7274 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7275             }
7276             }
7277              
7278             # $scalar or @array
7279             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7280 0           $char[$i] = e_string($char[$i]);
7281 0 0         if ($ignorecase) {
7282 0           $char[$i] = '@{[Char::Elatin9::ignorecase(' . $char[$i] . ')]}';
7283             }
7284             }
7285              
7286             # quote character before ? + * {
7287             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7288 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7289             }
7290             else {
7291 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7292             }
7293             }
7294             }
7295              
7296             # make regexp string
7297 0           $modifier =~ tr/i//d;
7298 0 0         if ($left_e > $right_e) {
7299 0           return join '', 'Char::Elatin9::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7300             }
7301 0           return join '', 'Char::Elatin9::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7302             }
7303              
7304             #
7305             # escape regexp of split qr''
7306             #
7307             sub e_split_q {
7308 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7309 0   0       $modifier ||= '';
7310              
7311 0           $modifier =~ tr/p//d;
7312 0 0         if ($modifier =~ /([adlu])/oxms) {
7313 0           my $line = 0;
7314 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7315 0 0         if ($filename ne __FILE__) {
7316 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7317 0           last;
7318             }
7319             }
7320 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7321             }
7322              
7323 0           $slash = 'div';
7324              
7325             # /b /B modifier
7326 0 0         if ($modifier =~ tr/bB//d) {
7327 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7328             }
7329              
7330 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7331              
7332             # split regexp
7333 0           my @char = $string =~ /\G(
7334             \[\:\^ [a-z]+ \:\] |
7335             \[\: [a-z]+ \:\] |
7336             \[\^ |
7337             \\? (?:$q_char)
7338             )/oxmsg;
7339              
7340             # unescape character
7341 0           for (my $i=0; $i <= $#char; $i++) {
7342 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7343             }
7344              
7345             # open character class [...]
7346 0           elsif ($char[$i] eq '[') {
7347 0           my $left = $i;
7348 0 0         if ($char[$i+1] eq ']') {
7349 0           $i++;
7350             }
7351 0           while (1) {
7352 0 0         if (++$i > $#char) {
7353 0           die __FILE__, ": Unmatched [] in regexp";
7354             }
7355 0 0         if ($char[$i] eq ']') {
7356 0           my $right = $i;
7357              
7358             # [...]
7359 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
7360              
7361 0           $i = $left;
7362 0           last;
7363             }
7364             }
7365             }
7366              
7367             # open character class [^...]
7368             elsif ($char[$i] eq '[^') {
7369 0           my $left = $i;
7370 0 0         if ($char[$i+1] eq ']') {
7371 0           $i++;
7372             }
7373 0           while (1) {
7374 0 0         if (++$i > $#char) {
7375 0           die __FILE__, ": Unmatched [] in regexp";
7376             }
7377 0 0         if ($char[$i] eq ']') {
7378 0           my $right = $i;
7379              
7380             # [^...]
7381 0           splice @char, $left, $right-$left+1, Char::Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7382              
7383 0           $i = $left;
7384 0           last;
7385             }
7386             }
7387             }
7388              
7389             # rewrite character class or escape character
7390             elsif (my $char = character_class($char[$i],$modifier)) {
7391 0           $char[$i] = $char;
7392             }
7393              
7394             # split(m/^/) --> split(m/^/m)
7395             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7396 0           $modifier .= 'm';
7397             }
7398              
7399             # /i modifier
7400             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin9::uc($char[$i]) ne Char::Elatin9::fc($char[$i]))) {
7401 0 0         if (CORE::length(Char::Elatin9::fc($char[$i])) == 1) {
7402 0           $char[$i] = '[' . Char::Elatin9::uc($char[$i]) . Char::Elatin9::fc($char[$i]) . ']';
7403             }
7404             else {
7405 0           $char[$i] = '(?:' . Char::Elatin9::uc($char[$i]) . '|' . Char::Elatin9::fc($char[$i]) . ')';
7406             }
7407             }
7408              
7409             # quote character before ? + * {
7410             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7411 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7412             }
7413             else {
7414 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7415             }
7416             }
7417             }
7418              
7419 0           $modifier =~ tr/i//d;
7420 0           return join '', 'Char::Elatin9::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7421             }
7422              
7423             #
7424             # instead of Carp::carp
7425             #
7426             sub carp {
7427 0     0 0   my($package,$filename,$line) = caller(1);
7428 0           print STDERR "@_ at $filename line $line.\n";
7429             }
7430              
7431             #
7432             # instead of Carp::croak
7433             #
7434             sub croak {
7435 0     0 0   my($package,$filename,$line) = caller(1);
7436 0           print STDERR "@_ at $filename line $line.\n";
7437 0           die "\n";
7438             }
7439              
7440             #
7441             # instead of Carp::cluck
7442             #
7443             sub cluck {
7444 0     0 0   my $i = 0;
7445 0           my @cluck = ();
7446 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7447 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7448 0           $i++;
7449             }
7450 0           print STDERR CORE::reverse @cluck;
7451 0           print STDERR "\n";
7452 0           carp @_;
7453             }
7454              
7455             #
7456             # instead of Carp::confess
7457             #
7458             sub confess {
7459 0     0 0   my $i = 0;
7460 0           my @confess = ();
7461 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7462 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7463 0           $i++;
7464             }
7465 0           print STDERR CORE::reverse @confess;
7466 0           print STDERR "\n";
7467 0           croak @_;
7468             }
7469              
7470             1;
7471              
7472             __END__