File Coverage

Char/Elatin3.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::Elatin3;
5             ######################################################################
6             #
7             # Char::Elatin3 - Run-time routines for Char/Latin3.pm
8             #
9             # http://search.cpan.org/dist/Char-Latin3/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
12             ######################################################################
13              
14 197     197   4660 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         637  
  197         10568  
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   13653 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1152  
  197         327  
  197         37768  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 197 50   197   1705 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 197         283 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 197         43897 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   13760 CORE::eval q{
  197     197   1195  
  197     62   341  
  197         29555  
  62         12619  
  69         11523  
  78         14665  
  66         11472  
  53         10511  
  66         11292  
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       122886 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   686 my $genpkg = "Symbol::";
62 197         10220 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::Elatin3::index($name, '::') == -1) && (Char::Elatin3::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   420 if (CORE::eval { local $@; CORE::require strict }) {
  197         383  
  197         2227  
110 197         42377 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   14753 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  197     197   1266  
  197         360  
  197         14760  
140 197     197   23568 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  197     197   1213  
  197         381  
  197         14462  
141 197     197   14034 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  197     197   1099  
  197         412  
  197         18813  
142              
143             #
144             # Latin-3 character range per length
145             #
146             my %range_tr = ();
147              
148             #
149             # alias of encoding name
150             #
151 197     197   11967 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  197     197   1341  
  197         326  
  197         409194  
152              
153             #
154             # Latin-3 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 Elatin3 \z/oxms) {
170             %range_tr = (
171             1 => [ [0x00..0xFF],
172             ],
173             );
174             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-3 | iec[- ]?8859-3 | latin-?3 ) \b /oxmsi;
175              
176             %lc = (%lc,
177             "\xA1" => "\xB1", # LATIN LETTER H WITH STROKE
178             "\xA6" => "\xB6", # LATIN LETTER H WITH CIRCUMFLEX
179             "\xAA" => "\xBA", # LATIN LETTER S WITH CEDILLA
180             "\xAB" => "\xBB", # LATIN LETTER G WITH BREVE
181             "\xAC" => "\xBC", # LATIN LETTER J WITH CIRCUMFLEX
182             "\xAF" => "\xBF", # LATIN LETTER Z WITH DOT ABOVE
183             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
184             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
185             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
186             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
187             "\xC5" => "\xE5", # LATIN LETTER C WITH DOT ABOVE
188             "\xC6" => "\xE6", # LATIN LETTER C WITH CIRCUMFLEX
189             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
190             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
191             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
192             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
193             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
194             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
195             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
196             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
197             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
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 G WITH DOT ABOVE
203             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
204             "\xD8" => "\xF8", # LATIN LETTER G WITH CIRCUMFLEX
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 U WITH BREVE
210             "\xDE" => "\xFE", # LATIN LETTER S WITH CIRCUMFLEX
211             );
212              
213             %uc = (%uc,
214             "\xB1" => "\xA1", # LATIN LETTER H WITH STROKE
215             "\xB6" => "\xA6", # LATIN LETTER H WITH CIRCUMFLEX
216             "\xBA" => "\xAA", # LATIN LETTER S WITH CEDILLA
217             "\xBB" => "\xAB", # LATIN LETTER G WITH BREVE
218             "\xBC" => "\xAC", # LATIN LETTER J WITH CIRCUMFLEX
219             "\xBF" => "\xAF", # LATIN LETTER Z WITH DOT ABOVE
220             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
221             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
222             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
223             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
224             "\xE5" => "\xC5", # LATIN LETTER C WITH DOT ABOVE
225             "\xE6" => "\xC6", # LATIN LETTER C WITH CIRCUMFLEX
226             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
227             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
228             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
229             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
230             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
231             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
232             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
233             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
234             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
235             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
236             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
237             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
238             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
239             "\xF5" => "\xD5", # LATIN LETTER G WITH DOT ABOVE
240             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
241             "\xF8" => "\xD8", # LATIN LETTER G WITH CIRCUMFLEX
242             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
243             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
244             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
245             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
246             "\xFD" => "\xDD", # LATIN LETTER U WITH BREVE
247             "\xFE" => "\xDE", # LATIN LETTER S WITH CIRCUMFLEX
248             );
249              
250             %fc = (%fc,
251             "\xA1" => "\xB1", # LATIN CAPITAL LETTER H WITH STROKE --> LATIN SMALL LETTER H WITH STROKE
252             "\xA6" => "\xB6", # LATIN CAPITAL LETTER H WITH CIRCUMFLEX --> LATIN SMALL LETTER H WITH CIRCUMFLEX
253              
254             # CaseFolding-6.1.0.txt
255             # Date: 2011-07-25, 21:21:56 GMT [MD]
256             #
257             # T: special case for uppercase I and dotted uppercase I
258             # - For non-Turkic languages, this mapping is normally not used.
259             # - For Turkic languages (tr, az), this mapping can be used instead of the normal mapping for these characters.
260             # Note that the Turkic mappings do not maintain canonical equivalence without additional processing.
261             # See the discussions of case mapping in the Unicode Standard for more information.
262              
263             #-------------------------------------------------------------------------------
264             "\xA9" => "\x69", # LATIN CAPITAL LETTER I WITH DOT ABOVE
265             # --> LATIN SMALL LETTER I (without COMBINING DOT ABOVE)
266             #-------------------------------------------------------------------------------
267              
268             "\xAA" => "\xBA", # LATIN CAPITAL LETTER S WITH CEDILLA --> LATIN SMALL LETTER S WITH CEDILLA
269             "\xAB" => "\xBB", # LATIN CAPITAL LETTER G WITH BREVE --> LATIN SMALL LETTER G WITH BREVE
270             "\xAC" => "\xBC", # LATIN CAPITAL LETTER J WITH CIRCUMFLEX --> LATIN SMALL LETTER J WITH CIRCUMFLEX
271             "\xAF" => "\xBF", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
272             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
273             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
274             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
275             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
276             "\xC5" => "\xE5", # LATIN CAPITAL LETTER C WITH DOT ABOVE --> LATIN SMALL LETTER C WITH DOT ABOVE
277             "\xC6" => "\xE6", # LATIN CAPITAL LETTER C WITH CIRCUMFLEX --> LATIN SMALL LETTER C WITH CIRCUMFLEX
278             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
279             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
280             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
281             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
282             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
283             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
284             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
285             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
286             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
287             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
288             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
289             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
290             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
291             "\xD5" => "\xF5", # LATIN CAPITAL LETTER G WITH DOT ABOVE --> LATIN SMALL LETTER G WITH DOT ABOVE
292             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
293             "\xD8" => "\xF8", # LATIN CAPITAL LETTER G WITH CIRCUMFLEX --> LATIN SMALL LETTER G WITH CIRCUMFLEX
294             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
295             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
296             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
297             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
298             "\xDD" => "\xFD", # LATIN CAPITAL LETTER U WITH BREVE --> LATIN SMALL LETTER U WITH BREVE
299             "\xDE" => "\xFE", # LATIN CAPITAL LETTER S WITH CIRCUMFLEX --> LATIN SMALL LETTER S WITH CIRCUMFLEX
300             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
301             );
302             }
303              
304             else {
305             croak "Don't know my package name '@{[__PACKAGE__]}'";
306             }
307              
308             #
309             # @ARGV wildcard globbing
310             #
311             sub import {
312              
313 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
314 0         0 my @argv = ();
315 0         0 for (@ARGV) {
316              
317             # has space
318 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
319 0 0       0 if (my @glob = Char::Elatin3::glob(qq{"$_"})) {
320 0         0 push @argv, @glob;
321             }
322             else {
323 0         0 push @argv, $_;
324             }
325             }
326              
327             # has wildcard metachar
328             elsif (/\A (?:$q_char)*? [*?] /oxms) {
329 0 0       0 if (my @glob = Char::Elatin3::glob($_)) {
330 0         0 push @argv, @glob;
331             }
332             else {
333 0         0 push @argv, $_;
334             }
335             }
336              
337             # no wildcard globbing
338             else {
339 0         0 push @argv, $_;
340             }
341             }
342 0         0 @ARGV = @argv;
343             }
344             }
345              
346             # P.230 Care with Prototypes
347             # in Chapter 6: Subroutines
348             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
349             #
350             # If you aren't careful, you can get yourself into trouble with prototypes.
351             # But if you are careful, you can do a lot of neat things with them. This is
352             # all very powerful, of course, and should only be used in moderation to make
353             # the world a better place.
354              
355             # P.332 Care with Prototypes
356             # in Chapter 7: Subroutines
357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
358             #
359             # If you aren't careful, you can get yourself into trouble with prototypes.
360             # But if you are careful, you can do a lot of neat things with them. This is
361             # all very powerful, of course, and should only be used in moderation to make
362             # the world a better place.
363              
364             #
365             # Prototypes of subroutines
366             #
367 0     0   0 sub unimport {}
368             sub Char::Elatin3::split(;$$$);
369             sub Char::Elatin3::tr($$$$;$);
370             sub Char::Elatin3::chop(@);
371             sub Char::Elatin3::index($$;$);
372             sub Char::Elatin3::rindex($$;$);
373             sub Char::Elatin3::lcfirst(@);
374             sub Char::Elatin3::lcfirst_();
375             sub Char::Elatin3::lc(@);
376             sub Char::Elatin3::lc_();
377             sub Char::Elatin3::ucfirst(@);
378             sub Char::Elatin3::ucfirst_();
379             sub Char::Elatin3::uc(@);
380             sub Char::Elatin3::uc_();
381             sub Char::Elatin3::fc(@);
382             sub Char::Elatin3::fc_();
383             sub Char::Elatin3::ignorecase;
384             sub Char::Elatin3::classic_character_class;
385             sub Char::Elatin3::capture;
386             sub Char::Elatin3::chr(;$);
387             sub Char::Elatin3::chr_();
388             sub Char::Elatin3::glob($);
389             sub Char::Elatin3::glob_();
390              
391             sub Char::Latin3::ord(;$);
392             sub Char::Latin3::ord_();
393             sub Char::Latin3::reverse(@);
394             sub Char::Latin3::getc(;*@);
395             sub Char::Latin3::length(;$);
396             sub Char::Latin3::substr($$;$$);
397             sub Char::Latin3::index($$;$);
398             sub Char::Latin3::rindex($$;$);
399             sub Char::Latin3::escape(;$);
400              
401             #
402             # Regexp work
403             #
404 197     197   16909 BEGIN { CORE::eval q{ use vars qw(
  197     197   1470  
  197         537  
  197         97674  
405             $Char::Latin3::re_a
406             $Char::Latin3::re_t
407             $Char::Latin3::re_n
408             $Char::Latin3::re_r
409             ) } }
410              
411             #
412             # Character class
413             #
414 197     197   14988 BEGIN { CORE::eval q{ use vars qw(
  197     197   1127  
  197         341  
  197         3428515  
415             $dot
416             $dot_s
417             $eD
418             $eS
419             $eW
420             $eH
421             $eV
422             $eR
423             $eN
424             $not_alnum
425             $not_alpha
426             $not_ascii
427             $not_blank
428             $not_cntrl
429             $not_digit
430             $not_graph
431             $not_lower
432             $not_lower_i
433             $not_print
434             $not_punct
435             $not_space
436             $not_upper
437             $not_upper_i
438             $not_word
439             $not_xdigit
440             $eb
441             $eB
442             ) } }
443              
444             ${Char::Elatin3::dot} = qr{(?:[^\x0A])};
445             ${Char::Elatin3::dot_s} = qr{(?:[\x00-\xFF])};
446             ${Char::Elatin3::eD} = qr{(?:[^0-9])};
447              
448             # Vertical tabs are now whitespace
449             # \s in a regex now matches a vertical tab in all circumstances.
450             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
451             # ${Char::Elatin3::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
452             # ${Char::Elatin3::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
453             ${Char::Elatin3::eS} = qr{(?:[^\s])};
454              
455             ${Char::Elatin3::eW} = qr{(?:[^0-9A-Z_a-z])};
456             ${Char::Elatin3::eH} = qr{(?:[^\x09\x20])};
457             ${Char::Elatin3::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
458             ${Char::Elatin3::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
459             ${Char::Elatin3::eN} = qr{(?:[^\x0A])};
460             ${Char::Elatin3::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
461             ${Char::Elatin3::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
462             ${Char::Elatin3::not_ascii} = qr{(?:[^\x00-\x7F])};
463             ${Char::Elatin3::not_blank} = qr{(?:[^\x09\x20])};
464             ${Char::Elatin3::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
465             ${Char::Elatin3::not_digit} = qr{(?:[^\x30-\x39])};
466             ${Char::Elatin3::not_graph} = qr{(?:[^\x21-\x7F])};
467             ${Char::Elatin3::not_lower} = qr{(?:[^\x61-\x7A])};
468             ${Char::Elatin3::not_lower_i} = qr{(?:[\x00-\xFF])};
469             ${Char::Elatin3::not_print} = qr{(?:[^\x20-\x7F])};
470             ${Char::Elatin3::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
471             ${Char::Elatin3::not_space} = qr{(?:[^\s\x0B])};
472             ${Char::Elatin3::not_upper} = qr{(?:[^\x41-\x5A])};
473             ${Char::Elatin3::not_upper_i} = qr{(?:[\x00-\xFF])};
474             ${Char::Elatin3::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
475             ${Char::Elatin3::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
476             ${Char::Elatin3::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))};
477             ${Char::Elatin3::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]))};
478              
479             # avoid: Name "Char::Elatin3::foo" used only once: possible typo at here.
480             ${Char::Elatin3::dot} = ${Char::Elatin3::dot};
481             ${Char::Elatin3::dot_s} = ${Char::Elatin3::dot_s};
482             ${Char::Elatin3::eD} = ${Char::Elatin3::eD};
483             ${Char::Elatin3::eS} = ${Char::Elatin3::eS};
484             ${Char::Elatin3::eW} = ${Char::Elatin3::eW};
485             ${Char::Elatin3::eH} = ${Char::Elatin3::eH};
486             ${Char::Elatin3::eV} = ${Char::Elatin3::eV};
487             ${Char::Elatin3::eR} = ${Char::Elatin3::eR};
488             ${Char::Elatin3::eN} = ${Char::Elatin3::eN};
489             ${Char::Elatin3::not_alnum} = ${Char::Elatin3::not_alnum};
490             ${Char::Elatin3::not_alpha} = ${Char::Elatin3::not_alpha};
491             ${Char::Elatin3::not_ascii} = ${Char::Elatin3::not_ascii};
492             ${Char::Elatin3::not_blank} = ${Char::Elatin3::not_blank};
493             ${Char::Elatin3::not_cntrl} = ${Char::Elatin3::not_cntrl};
494             ${Char::Elatin3::not_digit} = ${Char::Elatin3::not_digit};
495             ${Char::Elatin3::not_graph} = ${Char::Elatin3::not_graph};
496             ${Char::Elatin3::not_lower} = ${Char::Elatin3::not_lower};
497             ${Char::Elatin3::not_lower_i} = ${Char::Elatin3::not_lower_i};
498             ${Char::Elatin3::not_print} = ${Char::Elatin3::not_print};
499             ${Char::Elatin3::not_punct} = ${Char::Elatin3::not_punct};
500             ${Char::Elatin3::not_space} = ${Char::Elatin3::not_space};
501             ${Char::Elatin3::not_upper} = ${Char::Elatin3::not_upper};
502             ${Char::Elatin3::not_upper_i} = ${Char::Elatin3::not_upper_i};
503             ${Char::Elatin3::not_word} = ${Char::Elatin3::not_word};
504             ${Char::Elatin3::not_xdigit} = ${Char::Elatin3::not_xdigit};
505             ${Char::Elatin3::eb} = ${Char::Elatin3::eb};
506             ${Char::Elatin3::eB} = ${Char::Elatin3::eB};
507              
508             #
509             # Latin-3 split
510             #
511             sub Char::Elatin3::split(;$$$) {
512              
513             # P.794 29.2.161. split
514             # in Chapter 29: Functions
515             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
516              
517             # P.951 split
518             # in Chapter 27: Functions
519             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
520              
521 0     0 0 0 my $pattern = $_[0];
522 0         0 my $string = $_[1];
523 0         0 my $limit = $_[2];
524              
525             # if $pattern is also omitted or is the literal space, " "
526 0 0       0 if (not defined $pattern) {
527 0         0 $pattern = ' ';
528             }
529              
530             # if $string is omitted, the function splits the $_ string
531 0 0       0 if (not defined $string) {
532 0 0       0 if (defined $_) {
533 0         0 $string = $_;
534             }
535             else {
536 0         0 $string = '';
537             }
538             }
539              
540 0         0 my @split = ();
541              
542             # when string is empty
543 0 0       0 if ($string eq '') {
    0          
544              
545             # resulting list value in list context
546 0 0       0 if (wantarray) {
547 0         0 return @split;
548             }
549              
550             # count of substrings in scalar context
551             else {
552 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
553 0         0 @_ = @split;
554 0         0 return scalar @_;
555             }
556             }
557              
558             # split's first argument is more consistently interpreted
559             #
560             # After some changes earlier in v5.17, split's behavior has been simplified:
561             # if the PATTERN argument evaluates to a string containing one space, it is
562             # treated the way that a literal string containing one space once was.
563             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
564              
565             # if $pattern is also omitted or is the literal space, " ", the function splits
566             # on whitespace, /\s+/, after skipping any leading whitespace
567             # (and so on)
568              
569             elsif ($pattern eq ' ') {
570 0 0       0 if (not defined $limit) {
571 0         0 return CORE::split(' ', $string);
572             }
573             else {
574 0         0 return CORE::split(' ', $string, $limit);
575             }
576             }
577              
578             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
579 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
580              
581             # a pattern capable of matching either the null string or something longer than the
582             # null string will split the value of $string into separate characters wherever it
583             # matches the null string between characters
584             # (and so on)
585              
586 0 0       0 if ('' =~ / \A $pattern \z /xms) {
587 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
588 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
589              
590             # P.1024 Appendix W.10 Multibyte Processing
591             # of ISBN 1-56592-224-7 CJKV Information Processing
592             # (and so on)
593              
594             # the //m modifier is assumed when you split on the pattern /^/
595             # (and so on)
596              
597             # V
598 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
599              
600             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
601             # is included in the resulting list, interspersed with the fields that are ordinarily returned
602             # (and so on)
603              
604 0         0 local $@;
605 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
606 0         0 push @split, CORE::eval('$' . $digit);
607             }
608             }
609             }
610              
611             else {
612 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
613              
614             # V
615 0         0 while ($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              
624             elsif ($limit > 0) {
625 0 0       0 if ('' =~ / \A $pattern \z /xms) {
626 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
627 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
628              
629             # V
630 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
631 0         0 local $@;
632 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
633 0         0 push @split, CORE::eval('$' . $digit);
634             }
635             }
636             }
637             }
638             else {
639 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
640 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
641              
642             # V
643 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
644 0         0 local $@;
645 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
646 0         0 push @split, CORE::eval('$' . $digit);
647             }
648             }
649             }
650             }
651             }
652              
653 0 0       0 if (CORE::length($string) > 0) {
654 0         0 push @split, $string;
655             }
656              
657             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
658 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
659 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
660 0         0 pop @split;
661             }
662             }
663              
664             # resulting list value in list context
665 0 0       0 if (wantarray) {
666 0         0 return @split;
667             }
668              
669             # count of substrings in scalar context
670             else {
671 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
672 0         0 @_ = @split;
673 0         0 return scalar @_;
674             }
675             }
676              
677             #
678             # get last subexpression offsets
679             #
680             sub _last_subexpression_offsets {
681 0     0   0 my $pattern = $_[0];
682              
683             # remove comment
684 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
685              
686 0         0 my $modifier = '';
687 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
688 0         0 $modifier = $1;
689 0         0 $modifier =~ s/-[A-Za-z]*//;
690             }
691              
692             # with /x modifier
693 0         0 my @char = ();
694 0 0       0 if ($modifier =~ /x/oxms) {
695 0         0 @char = $pattern =~ /\G(
696             \\ (?:$q_char) |
697             \# (?:$q_char)*? $ |
698             \[ (?: \\\] | (?:$q_char))+? \] |
699             \(\? |
700             (?:$q_char)
701             )/oxmsg;
702             }
703              
704             # without /x modifier
705             else {
706 0         0 @char = $pattern =~ /\G(
707             \\ (?:$q_char) |
708             \[ (?: \\\] | (?:$q_char))+? \] |
709             \(\? |
710             (?:$q_char)
711             )/oxmsg;
712             }
713              
714 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
715             }
716              
717             #
718             # Latin-3 transliteration (tr///)
719             #
720             sub Char::Elatin3::tr($$$$;$) {
721              
722 0     0 0 0 my $bind_operator = $_[1];
723 0         0 my $searchlist = $_[2];
724 0         0 my $replacementlist = $_[3];
725 0   0     0 my $modifier = $_[4] || '';
726              
727 0 0       0 if ($modifier =~ /r/oxms) {
728 0 0       0 if ($bind_operator =~ / !~ /oxms) {
729 0         0 croak "Using !~ with tr///r doesn't make sense";
730             }
731             }
732              
733 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
734 0         0 my @searchlist = _charlist_tr($searchlist);
735 0         0 my @replacementlist = _charlist_tr($replacementlist);
736              
737 0         0 my %tr = ();
738 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
739 0 0       0 if (not exists $tr{$searchlist[$i]}) {
740 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
741 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
742             }
743             elsif ($modifier =~ /d/oxms) {
744 0         0 $tr{$searchlist[$i]} = '';
745             }
746             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
747 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
748             }
749             else {
750 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
751             }
752             }
753             }
754              
755 0         0 my $tr = 0;
756 0         0 my $replaced = '';
757 0 0       0 if ($modifier =~ /c/oxms) {
758 0         0 while (defined(my $char = shift @char)) {
759 0 0       0 if (not exists $tr{$char}) {
760 0 0       0 if (defined $replacementlist[0]) {
761 0         0 $replaced .= $replacementlist[0];
762             }
763 0         0 $tr++;
764 0 0       0 if ($modifier =~ /s/oxms) {
765 0   0     0 while (@char and (not exists $tr{$char[0]})) {
766 0         0 shift @char;
767 0         0 $tr++;
768             }
769             }
770             }
771             else {
772 0         0 $replaced .= $char;
773             }
774             }
775             }
776             else {
777 0         0 while (defined(my $char = shift @char)) {
778 0 0       0 if (exists $tr{$char}) {
779 0         0 $replaced .= $tr{$char};
780 0         0 $tr++;
781 0 0       0 if ($modifier =~ /s/oxms) {
782 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
783 0         0 shift @char;
784 0         0 $tr++;
785             }
786             }
787             }
788             else {
789 0         0 $replaced .= $char;
790             }
791             }
792             }
793              
794 0 0       0 if ($modifier =~ /r/oxms) {
795 0         0 return $replaced;
796             }
797             else {
798 0         0 $_[0] = $replaced;
799 0 0       0 if ($bind_operator =~ / !~ /oxms) {
800 0         0 return not $tr;
801             }
802             else {
803 0         0 return $tr;
804             }
805             }
806             }
807              
808             #
809             # Latin-3 chop
810             #
811             sub Char::Elatin3::chop(@) {
812              
813 0     0 0 0 my $chop;
814 0 0       0 if (@_ == 0) {
815 0         0 my @char = /\G ($q_char) /oxmsg;
816 0         0 $chop = pop @char;
817 0         0 $_ = join '', @char;
818             }
819             else {
820 0         0 for (@_) {
821 0         0 my @char = /\G ($q_char) /oxmsg;
822 0         0 $chop = pop @char;
823 0         0 $_ = join '', @char;
824             }
825             }
826 0         0 return $chop;
827             }
828              
829             #
830             # Latin-3 index by octet
831             #
832             sub Char::Elatin3::index($$;$) {
833              
834 0     0 1 0 my($str,$substr,$position) = @_;
835 0   0     0 $position ||= 0;
836 0         0 my $pos = 0;
837              
838 0         0 while ($pos < CORE::length($str)) {
839 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
840 0 0       0 if ($pos >= $position) {
841 0         0 return $pos;
842             }
843             }
844 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
845 0         0 $pos += CORE::length($1);
846             }
847             else {
848 0         0 $pos += 1;
849             }
850             }
851 0         0 return -1;
852             }
853              
854             #
855             # Latin-3 reverse index
856             #
857             sub Char::Elatin3::rindex($$;$) {
858              
859 0     0 0 0 my($str,$substr,$position) = @_;
860 0   0     0 $position ||= CORE::length($str) - 1;
861 0         0 my $pos = 0;
862 0         0 my $rindex = -1;
863              
864 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
865 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
866 0         0 $rindex = $pos;
867             }
868 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
869 0         0 $pos += CORE::length($1);
870             }
871             else {
872 0         0 $pos += 1;
873             }
874             }
875 0         0 return $rindex;
876             }
877              
878             #
879             # Latin-3 lower case first with parameter
880             #
881             sub Char::Elatin3::lcfirst(@) {
882 0 0   0 0 0 if (@_) {
883 0         0 my $s = shift @_;
884 0 0 0     0 if (@_ and wantarray) {
885 0         0 return Char::Elatin3::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
886             }
887             else {
888 0         0 return Char::Elatin3::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
889             }
890             }
891             else {
892 0         0 return Char::Elatin3::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
893             }
894             }
895              
896             #
897             # Latin-3 lower case first without parameter
898             #
899             sub Char::Elatin3::lcfirst_() {
900 0     0 0 0 return Char::Elatin3::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
901             }
902              
903             #
904             # Latin-3 lower case with parameter
905             #
906             sub Char::Elatin3::lc(@) {
907 0 0   0 0 0 if (@_) {
908 0         0 my $s = shift @_;
909 0 0 0     0 if (@_ and wantarray) {
910 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
911             }
912             else {
913 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
914             }
915             }
916             else {
917 0         0 return Char::Elatin3::lc_();
918             }
919             }
920              
921             #
922             # Latin-3 lower case without parameter
923             #
924             sub Char::Elatin3::lc_() {
925 0     0 0 0 my $s = $_;
926 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
927             }
928              
929             #
930             # Latin-3 upper case first with parameter
931             #
932             sub Char::Elatin3::ucfirst(@) {
933 0 0   0 0 0 if (@_) {
934 0         0 my $s = shift @_;
935 0 0 0     0 if (@_ and wantarray) {
936 0         0 return Char::Elatin3::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
937             }
938             else {
939 0         0 return Char::Elatin3::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
940             }
941             }
942             else {
943 0         0 return Char::Elatin3::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
944             }
945             }
946              
947             #
948             # Latin-3 upper case first without parameter
949             #
950             sub Char::Elatin3::ucfirst_() {
951 0     0 0 0 return Char::Elatin3::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
952             }
953              
954             #
955             # Latin-3 upper case with parameter
956             #
957             sub Char::Elatin3::uc(@) {
958 0 0   0 0 0 if (@_) {
959 0         0 my $s = shift @_;
960 0 0 0     0 if (@_ and wantarray) {
961 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
962             }
963             else {
964 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
965             }
966             }
967             else {
968 0         0 return Char::Elatin3::uc_();
969             }
970             }
971              
972             #
973             # Latin-3 upper case without parameter
974             #
975             sub Char::Elatin3::uc_() {
976 0     0 0 0 my $s = $_;
977 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
978             }
979              
980             #
981             # Latin-3 fold case with parameter
982             #
983             sub Char::Elatin3::fc(@) {
984 0 0   0 0 0 if (@_) {
985 0         0 my $s = shift @_;
986 0 0 0     0 if (@_ and wantarray) {
987 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
988             }
989             else {
990 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
991             }
992             }
993             else {
994 0         0 return Char::Elatin3::fc_();
995             }
996             }
997              
998             #
999             # Latin-3 fold case without parameter
1000             #
1001             sub Char::Elatin3::fc_() {
1002 0     0 0 0 my $s = $_;
1003 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1004             }
1005              
1006             #
1007             # Latin-3 regexp capture
1008             #
1009             {
1010             sub Char::Elatin3::capture {
1011 0     0 1 0 return $_[0];
1012             }
1013             }
1014              
1015             #
1016             # Latin-3 regexp ignore case modifier
1017             #
1018             sub Char::Elatin3::ignorecase {
1019              
1020 0     0 0 0 my @string = @_;
1021 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1022              
1023             # ignore case of $scalar or @array
1024 0         0 for my $string (@string) {
1025              
1026             # split regexp
1027 0         0 my @char = $string =~ /\G(
1028             \[\^ |
1029             \\? (?:$q_char)
1030             )/oxmsg;
1031              
1032             # unescape character
1033 0         0 for (my $i=0; $i <= $#char; $i++) {
1034 0 0       0 next if not defined $char[$i];
1035              
1036             # open character class [...]
1037 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1038 0         0 my $left = $i;
1039              
1040             # [] make die "unmatched [] in regexp ..."
1041              
1042 0 0       0 if ($char[$i+1] eq ']') {
1043 0         0 $i++;
1044             }
1045              
1046 0         0 while (1) {
1047 0 0       0 if (++$i > $#char) {
1048 0         0 croak "Unmatched [] in regexp";
1049             }
1050 0 0       0 if ($char[$i] eq ']') {
1051 0         0 my $right = $i;
1052 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1053              
1054             # escape character
1055 0         0 for my $char (@charlist) {
1056 0 0       0 if (0) {
1057             }
1058              
1059 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1060 0         0 $char = $1 . '\\' . $char;
1061             }
1062             }
1063              
1064             # [...]
1065 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1066              
1067 0         0 $i = $left;
1068 0         0 last;
1069             }
1070             }
1071             }
1072              
1073             # open character class [^...]
1074             elsif ($char[$i] eq '[^') {
1075 0         0 my $left = $i;
1076              
1077             # [^] make die "unmatched [] in regexp ..."
1078              
1079 0 0       0 if ($char[$i+1] eq ']') {
1080 0         0 $i++;
1081             }
1082              
1083 0         0 while (1) {
1084 0 0       0 if (++$i > $#char) {
1085 0         0 croak "Unmatched [] in regexp";
1086             }
1087 0 0       0 if ($char[$i] eq ']') {
1088 0         0 my $right = $i;
1089 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1090              
1091             # escape character
1092 0         0 for my $char (@charlist) {
1093 0 0       0 if (0) {
1094             }
1095              
1096 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1097 0         0 $char = '\\' . $char;
1098             }
1099             }
1100              
1101             # [^...]
1102 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1103              
1104 0         0 $i = $left;
1105 0         0 last;
1106             }
1107             }
1108             }
1109              
1110             # rewrite classic character class or escape character
1111             elsif (my $char = classic_character_class($char[$i])) {
1112 0         0 $char[$i] = $char;
1113             }
1114              
1115             # with /i modifier
1116             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1117 0         0 my $uc = Char::Elatin3::uc($char[$i]);
1118 0         0 my $fc = Char::Elatin3::fc($char[$i]);
1119 0 0       0 if ($uc ne $fc) {
1120 0 0       0 if (CORE::length($fc) == 1) {
1121 0         0 $char[$i] = '[' . $uc . $fc . ']';
1122             }
1123             else {
1124 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1125             }
1126             }
1127             }
1128             }
1129              
1130             # characterize
1131 0         0 for (my $i=0; $i <= $#char; $i++) {
1132 0 0       0 next if not defined $char[$i];
1133              
1134 0 0       0 if (0) {
1135             }
1136              
1137             # quote character before ? + * {
1138 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1139 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1140 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1141             }
1142             }
1143             }
1144              
1145 0         0 $string = join '', @char;
1146             }
1147              
1148             # make regexp string
1149 0         0 return @string;
1150             }
1151              
1152             #
1153             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1154             #
1155             sub Char::Elatin3::classic_character_class {
1156 0     0 0 0 my($char) = @_;
1157              
1158             return {
1159 0   0     0 '\D' => '${Char::Elatin3::eD}',
1160             '\S' => '${Char::Elatin3::eS}',
1161             '\W' => '${Char::Elatin3::eW}',
1162             '\d' => '[0-9]',
1163              
1164             # Before Perl 5.6, \s only matched the five whitespace characters
1165             # tab, newline, form-feed, carriage return, and the space character
1166             # itself, which, taken together, is the character class [\t\n\f\r ].
1167              
1168             # Vertical tabs are now whitespace
1169             # \s in a regex now matches a vertical tab in all circumstances.
1170             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1171             # \t \n \v \f \r space
1172             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1173             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1174             '\s' => '\s',
1175              
1176             '\w' => '[0-9A-Z_a-z]',
1177             '\C' => '[\x00-\xFF]',
1178             '\X' => 'X',
1179              
1180             # \h \v \H \V
1181              
1182             # P.114 Character Class Shortcuts
1183             # in Chapter 7: In the World of Regular Expressions
1184             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1185              
1186             # P.357 13.2.3 Whitespace
1187             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1188             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1189             #
1190             # 0x00009 CHARACTER TABULATION h s
1191             # 0x0000a LINE FEED (LF) vs
1192             # 0x0000b LINE TABULATION v
1193             # 0x0000c FORM FEED (FF) vs
1194             # 0x0000d CARRIAGE RETURN (CR) vs
1195             # 0x00020 SPACE h s
1196              
1197             # P.196 Table 5-9. Alphanumeric regex metasymbols
1198             # in Chapter 5. Pattern Matching
1199             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1200              
1201             # (and so on)
1202              
1203             '\H' => '${Char::Elatin3::eH}',
1204             '\V' => '${Char::Elatin3::eV}',
1205             '\h' => '[\x09\x20]',
1206             '\v' => '[\x0A\x0B\x0C\x0D]',
1207             '\R' => '${Char::Elatin3::eR}',
1208              
1209             # \N
1210             #
1211             # http://perldoc.perl.org/perlre.html
1212             # Character Classes and other Special Escapes
1213             # Any character but \n (experimental). Not affected by /s modifier
1214              
1215             '\N' => '${Char::Elatin3::eN}',
1216              
1217             # \b \B
1218              
1219             # P.180 Boundaries: The \b and \B Assertions
1220             # in Chapter 5: Pattern Matching
1221             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1222              
1223             # P.219 Boundaries: The \b and \B Assertions
1224             # in Chapter 5: Pattern Matching
1225             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1226              
1227             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1228             '\b' => '${Char::Elatin3::eb}',
1229              
1230             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1231             '\B' => '${Char::Elatin3::eB}',
1232              
1233             }->{$char} || '';
1234             }
1235              
1236             #
1237             # prepare Latin-3 characters per length
1238             #
1239              
1240             # 1 octet characters
1241             my @chars1 = ();
1242             sub chars1 {
1243 0 0   0 0 0 if (@chars1) {
1244 0         0 return @chars1;
1245             }
1246 0 0       0 if (exists $range_tr{1}) {
1247 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1248 0         0 while (my @range = splice(@ranges,0,1)) {
1249 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1250 0         0 push @chars1, pack 'C', $oct0;
1251             }
1252             }
1253             }
1254 0         0 return @chars1;
1255             }
1256              
1257             # 2 octets characters
1258             my @chars2 = ();
1259             sub chars2 {
1260 0 0   0 0 0 if (@chars2) {
1261 0         0 return @chars2;
1262             }
1263 0 0       0 if (exists $range_tr{2}) {
1264 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1265 0         0 while (my @range = splice(@ranges,0,2)) {
1266 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1267 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1268 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1269             }
1270             }
1271             }
1272             }
1273 0         0 return @chars2;
1274             }
1275              
1276             # 3 octets characters
1277             my @chars3 = ();
1278             sub chars3 {
1279 0 0   0 0 0 if (@chars3) {
1280 0         0 return @chars3;
1281             }
1282 0 0       0 if (exists $range_tr{3}) {
1283 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1284 0         0 while (my @range = splice(@ranges,0,3)) {
1285 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1286 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1287 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1288 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1289             }
1290             }
1291             }
1292             }
1293             }
1294 0         0 return @chars3;
1295             }
1296              
1297             # 4 octets characters
1298             my @chars4 = ();
1299             sub chars4 {
1300 0 0   0 0 0 if (@chars4) {
1301 0         0 return @chars4;
1302             }
1303 0 0       0 if (exists $range_tr{4}) {
1304 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1305 0         0 while (my @range = splice(@ranges,0,4)) {
1306 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1307 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1308 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1309 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1310 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1311             }
1312             }
1313             }
1314             }
1315             }
1316             }
1317 0         0 return @chars4;
1318             }
1319              
1320             #
1321             # Latin-3 open character list for tr
1322             #
1323             sub _charlist_tr {
1324              
1325 0     0   0 local $_ = shift @_;
1326              
1327             # unescape character
1328 0         0 my @char = ();
1329 0         0 while (not /\G \z/oxmsgc) {
1330 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1331 0         0 push @char, '\-';
1332             }
1333             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1334 0         0 push @char, CORE::chr(oct $1);
1335             }
1336             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1337 0         0 push @char, CORE::chr(hex $1);
1338             }
1339             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1340 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1341             }
1342             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1343 0         0 push @char, {
1344             '\0' => "\0",
1345             '\n' => "\n",
1346             '\r' => "\r",
1347             '\t' => "\t",
1348             '\f' => "\f",
1349             '\b' => "\x08", # \b means backspace in character class
1350             '\a' => "\a",
1351             '\e' => "\e",
1352             }->{$1};
1353             }
1354             elsif (/\G \\ ($q_char) /oxmsgc) {
1355 0         0 push @char, $1;
1356             }
1357             elsif (/\G ($q_char) /oxmsgc) {
1358 0         0 push @char, $1;
1359             }
1360             }
1361              
1362             # join separated multiple-octet
1363 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1364              
1365             # unescape '-'
1366 0         0 my @i = ();
1367 0         0 for my $i (0 .. $#char) {
1368 0 0       0 if ($char[$i] eq '\-') {
    0          
1369 0         0 $char[$i] = '-';
1370             }
1371             elsif ($char[$i] eq '-') {
1372 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1373 0         0 push @i, $i;
1374             }
1375             }
1376             }
1377              
1378             # open character list (reverse for splice)
1379 0         0 for my $i (CORE::reverse @i) {
1380 0         0 my @range = ();
1381              
1382             # range error
1383 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1384 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1385             }
1386              
1387             # range of multiple-octet code
1388 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1389 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1390 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1391             }
1392             elsif (CORE::length($char[$i+1]) == 2) {
1393 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1394 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1395             }
1396             elsif (CORE::length($char[$i+1]) == 3) {
1397 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1398 0         0 push @range, chars2();
1399 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1400             }
1401             elsif (CORE::length($char[$i+1]) == 4) {
1402 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1403 0         0 push @range, chars2();
1404 0         0 push @range, chars3();
1405 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1406             }
1407             else {
1408 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1409             }
1410             }
1411             elsif (CORE::length($char[$i-1]) == 2) {
1412 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1413 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1414             }
1415             elsif (CORE::length($char[$i+1]) == 3) {
1416 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1417 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1418             }
1419             elsif (CORE::length($char[$i+1]) == 4) {
1420 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1421 0         0 push @range, chars3();
1422 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1423             }
1424             else {
1425 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1426             }
1427             }
1428             elsif (CORE::length($char[$i-1]) == 3) {
1429 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1430 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1431             }
1432             elsif (CORE::length($char[$i+1]) == 4) {
1433 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1434 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1435             }
1436             else {
1437 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1438             }
1439             }
1440             elsif (CORE::length($char[$i-1]) == 4) {
1441 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1442 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1443             }
1444             else {
1445 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1446             }
1447             }
1448             else {
1449 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1450             }
1451              
1452 0         0 splice @char, $i-1, 3, @range;
1453             }
1454              
1455 0         0 return @char;
1456             }
1457              
1458             #
1459             # Latin-3 open character class
1460             #
1461             sub _cc {
1462 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1463 0         0 die __FILE__, ": subroutine cc got no parameter.";
1464             }
1465             elsif (scalar(@_) == 1) {
1466 0         0 return sprintf('\x%02X',$_[0]);
1467             }
1468             elsif (scalar(@_) == 2) {
1469 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1470 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1471             }
1472             elsif ($_[0] == $_[1]) {
1473 0         0 return sprintf('\x%02X',$_[0]);
1474             }
1475             elsif (($_[0]+1) == $_[1]) {
1476 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1477             }
1478             else {
1479 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1480             }
1481             }
1482             else {
1483 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1484             }
1485             }
1486              
1487             #
1488             # Latin-3 octet range
1489             #
1490             sub _octets {
1491 0     0   0 my $length = shift @_;
1492              
1493 0 0       0 if ($length == 1) {
1494 0         0 my($a1) = unpack 'C', $_[0];
1495 0         0 my($z1) = unpack 'C', $_[1];
1496              
1497 0 0       0 if ($a1 > $z1) {
1498 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1499             }
1500              
1501 0 0       0 if ($a1 == $z1) {
    0          
1502 0         0 return sprintf('\x%02X',$a1);
1503             }
1504             elsif (($a1+1) == $z1) {
1505 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1506             }
1507             else {
1508 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1509             }
1510             }
1511             else {
1512 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1513             }
1514             }
1515              
1516             #
1517             # Latin-3 range regexp
1518             #
1519             sub _range_regexp {
1520 0     0   0 my($length,$first,$last) = @_;
1521              
1522 0         0 my @range_regexp = ();
1523 0 0       0 if (not exists $range_tr{$length}) {
1524 0         0 return @range_regexp;
1525             }
1526              
1527 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1528 0         0 while (my @range = splice(@ranges,0,$length)) {
1529 0         0 my $min = '';
1530 0         0 my $max = '';
1531 0         0 for (my $i=0; $i < $length; $i++) {
1532 0         0 $min .= pack 'C', $range[$i][0];
1533 0         0 $max .= pack 'C', $range[$i][-1];
1534             }
1535              
1536             # min___max
1537             # FIRST_____________LAST
1538             # (nothing)
1539              
1540 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1541             }
1542              
1543             # **********
1544             # min_________max
1545             # FIRST_____________LAST
1546             # **********
1547              
1548             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1549 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1550             }
1551              
1552             # **********************
1553             # min________________max
1554             # FIRST_____________LAST
1555             # **********************
1556              
1557             elsif (($min eq $first) and ($max eq $last)) {
1558 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1559             }
1560              
1561             # *********
1562             # min___max
1563             # FIRST_____________LAST
1564             # *********
1565              
1566             elsif (($first le $min) and ($max le $last)) {
1567 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1568             }
1569              
1570             # **********************
1571             # min__________________________max
1572             # FIRST_____________LAST
1573             # **********************
1574              
1575             elsif (($min le $first) and ($last le $max)) {
1576 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1577             }
1578              
1579             # *********
1580             # min________max
1581             # FIRST_____________LAST
1582             # *********
1583              
1584             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1585 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1586             }
1587              
1588             # min___max
1589             # FIRST_____________LAST
1590             # (nothing)
1591              
1592             elsif ($last lt $min) {
1593             }
1594              
1595             else {
1596 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1597             }
1598             }
1599              
1600 0         0 return @range_regexp;
1601             }
1602              
1603             #
1604             # Latin-3 open character list for qr and not qr
1605             #
1606             sub _charlist {
1607              
1608 0     0   0 my $modifier = pop @_;
1609 0         0 my @char = @_;
1610              
1611 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1612              
1613             # unescape character
1614 0         0 for (my $i=0; $i <= $#char; $i++) {
1615              
1616             # escape - to ...
1617 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1618 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1619 0         0 $char[$i] = '...';
1620             }
1621             }
1622              
1623             # octal escape sequence
1624             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1625 0         0 $char[$i] = octchr($1);
1626             }
1627              
1628             # hexadecimal escape sequence
1629             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1630 0         0 $char[$i] = hexchr($1);
1631             }
1632              
1633             # \N{CHARNAME} --> N\{CHARNAME}
1634             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1635 0         0 $char[$i] = $1 . '\\' . $2;
1636             }
1637              
1638             # \p{PROPERTY} --> p\{PROPERTY}
1639             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1640 0         0 $char[$i] = $1 . '\\' . $2;
1641             }
1642              
1643             # \P{PROPERTY} --> P\{PROPERTY}
1644             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1645 0         0 $char[$i] = $1 . '\\' . $2;
1646             }
1647              
1648             # \p, \P, \X --> p, P, X
1649             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1650 0         0 $char[$i] = $1;
1651             }
1652              
1653             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1654 0         0 $char[$i] = CORE::chr oct $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1657 0         0 $char[$i] = CORE::chr hex $1;
1658             }
1659             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1660 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1661             }
1662             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1663 0         0 $char[$i] = {
1664             '\0' => "\0",
1665             '\n' => "\n",
1666             '\r' => "\r",
1667             '\t' => "\t",
1668             '\f' => "\f",
1669             '\b' => "\x08", # \b means backspace in character class
1670             '\a' => "\a",
1671             '\e' => "\e",
1672             '\d' => '[0-9]',
1673              
1674             # Vertical tabs are now whitespace
1675             # \s in a regex now matches a vertical tab in all circumstances.
1676             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1677             # \t \n \v \f \r space
1678             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1679             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1680             '\s' => '\s',
1681              
1682             '\w' => '[0-9A-Z_a-z]',
1683             '\D' => '${Char::Elatin3::eD}',
1684             '\S' => '${Char::Elatin3::eS}',
1685             '\W' => '${Char::Elatin3::eW}',
1686              
1687             '\H' => '${Char::Elatin3::eH}',
1688             '\V' => '${Char::Elatin3::eV}',
1689             '\h' => '[\x09\x20]',
1690             '\v' => '[\x0A\x0B\x0C\x0D]',
1691             '\R' => '${Char::Elatin3::eR}',
1692              
1693             }->{$1};
1694             }
1695              
1696             # POSIX-style character classes
1697             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1698 0         0 $char[$i] = {
1699              
1700             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1701             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1702             '[:^lower:]' => '${Char::Elatin3::not_lower_i}',
1703             '[:^upper:]' => '${Char::Elatin3::not_upper_i}',
1704              
1705             }->{$1};
1706             }
1707             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1708 0         0 $char[$i] = {
1709              
1710             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1711             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1712             '[:ascii:]' => '[\x00-\x7F]',
1713             '[:blank:]' => '[\x09\x20]',
1714             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1715             '[:digit:]' => '[\x30-\x39]',
1716             '[:graph:]' => '[\x21-\x7F]',
1717             '[:lower:]' => '[\x61-\x7A]',
1718             '[:print:]' => '[\x20-\x7F]',
1719             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1720              
1721             # P.174 POSIX-Style Character Classes
1722             # in Chapter 5: Pattern Matching
1723             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1724              
1725             # P.311 11.2.4 Character Classes and other Special Escapes
1726             # in Chapter 11: perlre: Perl regular expressions
1727             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1728              
1729             # P.210 POSIX-Style Character Classes
1730             # in Chapter 5: Pattern Matching
1731             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1732              
1733             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1734              
1735             '[:upper:]' => '[\x41-\x5A]',
1736             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1737             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1738             '[:^alnum:]' => '${Char::Elatin3::not_alnum}',
1739             '[:^alpha:]' => '${Char::Elatin3::not_alpha}',
1740             '[:^ascii:]' => '${Char::Elatin3::not_ascii}',
1741             '[:^blank:]' => '${Char::Elatin3::not_blank}',
1742             '[:^cntrl:]' => '${Char::Elatin3::not_cntrl}',
1743             '[:^digit:]' => '${Char::Elatin3::not_digit}',
1744             '[:^graph:]' => '${Char::Elatin3::not_graph}',
1745             '[:^lower:]' => '${Char::Elatin3::not_lower}',
1746             '[:^print:]' => '${Char::Elatin3::not_print}',
1747             '[:^punct:]' => '${Char::Elatin3::not_punct}',
1748             '[:^space:]' => '${Char::Elatin3::not_space}',
1749             '[:^upper:]' => '${Char::Elatin3::not_upper}',
1750             '[:^word:]' => '${Char::Elatin3::not_word}',
1751             '[:^xdigit:]' => '${Char::Elatin3::not_xdigit}',
1752              
1753             }->{$1};
1754             }
1755             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1756 0         0 $char[$i] = $1;
1757             }
1758             }
1759              
1760             # open character list
1761 0         0 my @singleoctet = ();
1762 0         0 my @multipleoctet = ();
1763 0         0 for (my $i=0; $i <= $#char; ) {
1764              
1765             # escaped -
1766 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1767 0         0 $i += 1;
1768 0         0 next;
1769             }
1770              
1771             # make range regexp
1772             elsif ($char[$i] eq '...') {
1773              
1774             # range error
1775 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1776 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1777             }
1778             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1779 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1780 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]);
1781             }
1782             }
1783              
1784             # make range regexp per length
1785 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1786 0         0 my @regexp = ();
1787              
1788             # is first and last
1789 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1790 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1791             }
1792              
1793             # is first
1794             elsif ($length == CORE::length($char[$i-1])) {
1795 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1796             }
1797              
1798             # is inside in first and last
1799             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1800 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1801             }
1802              
1803             # is last
1804             elsif ($length == CORE::length($char[$i+1])) {
1805 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1806             }
1807              
1808             else {
1809 0         0 die __FILE__, ": subroutine make_regexp panic.";
1810             }
1811              
1812 0 0       0 if ($length == 1) {
1813 0         0 push @singleoctet, @regexp;
1814             }
1815             else {
1816 0         0 push @multipleoctet, @regexp;
1817             }
1818             }
1819              
1820 0         0 $i += 2;
1821             }
1822              
1823             # with /i modifier
1824             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1825 0 0       0 if ($modifier =~ /i/oxms) {
1826 0         0 my $uc = Char::Elatin3::uc($char[$i]);
1827 0         0 my $fc = Char::Elatin3::fc($char[$i]);
1828 0 0       0 if ($uc ne $fc) {
1829 0 0       0 if (CORE::length($fc) == 1) {
1830 0         0 push @singleoctet, $uc, $fc;
1831             }
1832             else {
1833 0         0 push @singleoctet, $uc;
1834 0         0 push @multipleoctet, $fc;
1835             }
1836             }
1837             else {
1838 0         0 push @singleoctet, $char[$i];
1839             }
1840             }
1841             else {
1842 0         0 push @singleoctet, $char[$i];
1843             }
1844 0         0 $i += 1;
1845             }
1846              
1847             # single character of single octet code
1848             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1849 0         0 push @singleoctet, "\t", "\x20";
1850 0         0 $i += 1;
1851             }
1852             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1853 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1854 0         0 $i += 1;
1855             }
1856             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1857 0         0 push @singleoctet, $char[$i];
1858 0         0 $i += 1;
1859             }
1860              
1861             # single character of multiple-octet code
1862             else {
1863 0         0 push @multipleoctet, $char[$i];
1864 0         0 $i += 1;
1865             }
1866             }
1867              
1868             # quote metachar
1869 0         0 for (@singleoctet) {
1870 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1871 0         0 $_ = '-';
1872             }
1873             elsif (/\A \n \z/oxms) {
1874 0         0 $_ = '\n';
1875             }
1876             elsif (/\A \r \z/oxms) {
1877 0         0 $_ = '\r';
1878             }
1879             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1880 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1881             }
1882             elsif (/\A [\x00-\xFF] \z/oxms) {
1883 0         0 $_ = quotemeta $_;
1884             }
1885             }
1886              
1887             # return character list
1888 0         0 return \@singleoctet, \@multipleoctet;
1889             }
1890              
1891             #
1892             # Latin-3 octal escape sequence
1893             #
1894             sub octchr {
1895 0     0 0 0 my($octdigit) = @_;
1896              
1897 0         0 my @binary = ();
1898 0         0 for my $octal (split(//,$octdigit)) {
1899 0         0 push @binary, {
1900             '0' => '000',
1901             '1' => '001',
1902             '2' => '010',
1903             '3' => '011',
1904             '4' => '100',
1905             '5' => '101',
1906             '6' => '110',
1907             '7' => '111',
1908             }->{$octal};
1909             }
1910 0         0 my $binary = join '', @binary;
1911              
1912 0         0 my $octchr = {
1913             # 1234567
1914             1 => pack('B*', "0000000$binary"),
1915             2 => pack('B*', "000000$binary"),
1916             3 => pack('B*', "00000$binary"),
1917             4 => pack('B*', "0000$binary"),
1918             5 => pack('B*', "000$binary"),
1919             6 => pack('B*', "00$binary"),
1920             7 => pack('B*', "0$binary"),
1921             0 => pack('B*', "$binary"),
1922              
1923             }->{CORE::length($binary) % 8};
1924              
1925 0         0 return $octchr;
1926             }
1927              
1928             #
1929             # Latin-3 hexadecimal escape sequence
1930             #
1931             sub hexchr {
1932 0     0 0 0 my($hexdigit) = @_;
1933              
1934 0         0 my $hexchr = {
1935             1 => pack('H*', "0$hexdigit"),
1936             0 => pack('H*', "$hexdigit"),
1937              
1938             }->{CORE::length($_[0]) % 2};
1939              
1940 0         0 return $hexchr;
1941             }
1942              
1943             #
1944             # Latin-3 open character list for qr
1945             #
1946             sub charlist_qr {
1947              
1948 0     0 0 0 my $modifier = pop @_;
1949 0         0 my @char = @_;
1950              
1951 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1952 0         0 my @singleoctet = @$singleoctet;
1953 0         0 my @multipleoctet = @$multipleoctet;
1954              
1955             # return character list
1956 0 0       0 if (scalar(@singleoctet) >= 1) {
1957              
1958             # with /i modifier
1959 0 0       0 if ($modifier =~ m/i/oxms) {
1960 0         0 my %singleoctet_ignorecase = ();
1961 0         0 for (@singleoctet) {
1962 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1963 0         0 for my $ord (hex($1) .. hex($2)) {
1964 0         0 my $char = CORE::chr($ord);
1965 0         0 my $uc = Char::Elatin3::uc($char);
1966 0         0 my $fc = Char::Elatin3::fc($char);
1967 0 0       0 if ($uc eq $fc) {
1968 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1969             }
1970             else {
1971 0 0       0 if (CORE::length($fc) == 1) {
1972 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1973 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1974             }
1975             else {
1976 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1977 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1978             }
1979             }
1980             }
1981             }
1982 0 0       0 if ($_ ne '') {
1983 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1984             }
1985             }
1986 0         0 my $i = 0;
1987 0         0 my @singleoctet_ignorecase = ();
1988 0         0 for my $ord (0 .. 255) {
1989 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1990 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1991             }
1992             else {
1993 0         0 $i++;
1994             }
1995             }
1996 0         0 @singleoctet = ();
1997 0         0 for my $range (@singleoctet_ignorecase) {
1998 0 0       0 if (ref $range) {
1999 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2000 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2001             }
2002             elsif (scalar(@{$range}) == 2) {
2003 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2004             }
2005             else {
2006 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2007             }
2008             }
2009             }
2010             }
2011              
2012 0         0 my $not_anchor = '';
2013              
2014 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2015             }
2016 0 0       0 if (scalar(@multipleoctet) >= 2) {
2017 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2018             }
2019             else {
2020 0         0 return $multipleoctet[0];
2021             }
2022             }
2023              
2024             #
2025             # Latin-3 open character list for not qr
2026             #
2027             sub charlist_not_qr {
2028              
2029 0     0 0 0 my $modifier = pop @_;
2030 0         0 my @char = @_;
2031              
2032 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2033 0         0 my @singleoctet = @$singleoctet;
2034 0         0 my @multipleoctet = @$multipleoctet;
2035              
2036             # with /i modifier
2037 0 0       0 if ($modifier =~ m/i/oxms) {
2038 0         0 my %singleoctet_ignorecase = ();
2039 0         0 for (@singleoctet) {
2040 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2041 0         0 for my $ord (hex($1) .. hex($2)) {
2042 0         0 my $char = CORE::chr($ord);
2043 0         0 my $uc = Char::Elatin3::uc($char);
2044 0         0 my $fc = Char::Elatin3::fc($char);
2045 0 0       0 if ($uc eq $fc) {
2046 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2047             }
2048             else {
2049 0 0       0 if (CORE::length($fc) == 1) {
2050 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2051 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2052             }
2053             else {
2054 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2055 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2056             }
2057             }
2058             }
2059             }
2060 0 0       0 if ($_ ne '') {
2061 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2062             }
2063             }
2064 0         0 my $i = 0;
2065 0         0 my @singleoctet_ignorecase = ();
2066 0         0 for my $ord (0 .. 255) {
2067 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2068 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2069             }
2070             else {
2071 0         0 $i++;
2072             }
2073             }
2074 0         0 @singleoctet = ();
2075 0         0 for my $range (@singleoctet_ignorecase) {
2076 0 0       0 if (ref $range) {
2077 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2078 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2079             }
2080             elsif (scalar(@{$range}) == 2) {
2081 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2082             }
2083             else {
2084 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2085             }
2086             }
2087             }
2088             }
2089              
2090             # return character list
2091 0 0       0 if (scalar(@multipleoctet) >= 1) {
2092 0 0       0 if (scalar(@singleoctet) >= 1) {
2093              
2094             # any character other than multiple-octet and single octet character class
2095 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2096             }
2097             else {
2098              
2099             # any character other than multiple-octet character class
2100 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2101             }
2102             }
2103             else {
2104 0 0       0 if (scalar(@singleoctet) >= 1) {
2105              
2106             # any character other than single octet character class
2107 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2108             }
2109             else {
2110              
2111             # any character
2112 0         0 return "(?:$your_char)";
2113             }
2114             }
2115             }
2116              
2117             #
2118             # open file in read mode
2119             #
2120             sub _open_r {
2121 197     197   747 my(undef,$file) = @_;
2122 197         870 $file =~ s#\A (\s) #./$1#oxms;
2123 197   33     24479 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2124             open($_[0],"< $file\0");
2125             }
2126              
2127             #
2128             # open file in write mode
2129             #
2130             sub _open_w {
2131 0     0   0 my(undef,$file) = @_;
2132 0         0 $file =~ s#\A (\s) #./$1#oxms;
2133 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2134             open($_[0],"> $file\0");
2135             }
2136              
2137             #
2138             # open file in append mode
2139             #
2140             sub _open_a {
2141 0     0   0 my(undef,$file) = @_;
2142 0         0 $file =~ s#\A (\s) #./$1#oxms;
2143 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2144             open($_[0],">> $file\0");
2145             }
2146              
2147             #
2148             # safe system
2149             #
2150             sub _systemx {
2151              
2152             # P.707 29.2.33. exec
2153             # in Chapter 29: Functions
2154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2155             #
2156             # Be aware that in older releases of Perl, exec (and system) did not flush
2157             # your output buffer, so you needed to enable command buffering by setting $|
2158             # on one or more filehandles to avoid lost output in the case of exec, or
2159             # misordererd output in the case of system. This situation was largely remedied
2160             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2161              
2162             # P.855 exec
2163             # in Chapter 27: Functions
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165             #
2166             # In very old release of Perl (before v5.6), exec (and system) did not flush
2167             # your output buffer, so you needed to enable command buffering by setting $|
2168             # on one or more filehandles to avoid lost output with exec or misordered
2169             # output with system.
2170              
2171 197     197   722 $| = 1;
2172              
2173             # P.565 23.1.2. Cleaning Up Your Environment
2174             # in Chapter 23: Security
2175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2176              
2177             # P.656 Cleaning Up Your Environment
2178             # in Chapter 20: Security
2179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2180              
2181             # local $ENV{'PATH'} = '.';
2182 197         2315 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2183              
2184             # P.707 29.2.33. exec
2185             # in Chapter 29: Functions
2186             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2187             #
2188             # As we mentioned earlier, exec treats a discrete list of arguments as an
2189             # indication that it should bypass shell processing. However, there is one
2190             # place where you might still get tripped up. The exec call (and system, too)
2191             # will not distinguish between a single scalar argument and an array containing
2192             # only one element.
2193             #
2194             # @args = ("echo surprise"); # just one element in list
2195             # exec @args # still subject to shell escapes
2196             # or die "exec: $!"; # because @args == 1
2197             #
2198             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2199             # first argument as the pathname, which forces the rest of the arguments to be
2200             # interpreted as a list, even if there is only one of them:
2201             #
2202             # exec { $args[0] } @args # safe even with one-argument list
2203             # or die "can't exec @args: $!";
2204              
2205             # P.855 exec
2206             # in Chapter 27: Functions
2207             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2208             #
2209             # As we mentioned earlier, exec treats a discrete list of arguments as a
2210             # directive to bypass shell processing. However, there is one place where
2211             # you might still get tripped up. The exec call (and system, too) cannot
2212             # distinguish between a single scalar argument and an array containing
2213             # only one element.
2214             #
2215             # @args = ("echo surprise"); # just one element in list
2216             # exec @args # still subject to shell escapes
2217             # || die "exec: $!"; # because @args == 1
2218             #
2219             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2220             # argument as the pathname, which forces the rest of the arguments to be
2221             # interpreted as a list, even if there is only one of them:
2222             #
2223             # exec { $args[0] } @args # safe even with one-argument list
2224             # || die "can't exec @args: $!";
2225              
2226 197         523 return CORE::system { $_[0] } @_; # safe even with one-argument list
  197         23841547  
2227             }
2228              
2229             #
2230             # Latin-3 order to character (with parameter)
2231             #
2232             sub Char::Elatin3::chr(;$) {
2233              
2234 0 0   0 0   my $c = @_ ? $_[0] : $_;
2235              
2236 0 0         if ($c == 0x00) {
2237 0           return "\x00";
2238             }
2239             else {
2240 0           my @chr = ();
2241 0           while ($c > 0) {
2242 0           unshift @chr, ($c % 0x100);
2243 0           $c = int($c / 0x100);
2244             }
2245 0           return pack 'C*', @chr;
2246             }
2247             }
2248              
2249             #
2250             # Latin-3 order to character (without parameter)
2251             #
2252             sub Char::Elatin3::chr_() {
2253              
2254 0     0 0   my $c = $_;
2255              
2256 0 0         if ($c == 0x00) {
2257 0           return "\x00";
2258             }
2259             else {
2260 0           my @chr = ();
2261 0           while ($c > 0) {
2262 0           unshift @chr, ($c % 0x100);
2263 0           $c = int($c / 0x100);
2264             }
2265 0           return pack 'C*', @chr;
2266             }
2267             }
2268              
2269             #
2270             # Latin-3 path globbing (with parameter)
2271             #
2272             sub Char::Elatin3::glob($) {
2273              
2274 0 0   0 0   if (wantarray) {
2275 0           my @glob = _DOS_like_glob(@_);
2276 0           for my $glob (@glob) {
2277 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2278             }
2279 0           return @glob;
2280             }
2281             else {
2282 0           my $glob = _DOS_like_glob(@_);
2283 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2284 0           return $glob;
2285             }
2286             }
2287              
2288             #
2289             # Latin-3 path globbing (without parameter)
2290             #
2291             sub Char::Elatin3::glob_() {
2292              
2293 0 0   0 0   if (wantarray) {
2294 0           my @glob = _DOS_like_glob();
2295 0           for my $glob (@glob) {
2296 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2297             }
2298 0           return @glob;
2299             }
2300             else {
2301 0           my $glob = _DOS_like_glob();
2302 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2303 0           return $glob;
2304             }
2305             }
2306              
2307             #
2308             # Latin-3 path globbing via File::DosGlob 1.10
2309             #
2310             # Often I confuse "_dosglob" and "_doglob".
2311             # So, I renamed "_dosglob" to "_DOS_like_glob".
2312             #
2313             my %iter;
2314             my %entries;
2315             sub _DOS_like_glob {
2316              
2317             # context (keyed by second cxix argument provided by core)
2318 0     0     my($expr,$cxix) = @_;
2319              
2320             # glob without args defaults to $_
2321 0 0         $expr = $_ if not defined $expr;
2322              
2323             # represents the current user's home directory
2324             #
2325             # 7.3. Expanding Tildes in Filenames
2326             # in Chapter 7. File Access
2327             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2328             #
2329             # and File::HomeDir, File::HomeDir::Windows module
2330              
2331             # DOS-like system
2332 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2333 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2334 0           { my_home_MSWin32() }oxmse;
2335             }
2336              
2337             # UNIX-like system
2338             else {
2339 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2340 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2341             }
2342              
2343             # assume global context if not provided one
2344 0 0         $cxix = '_G_' if not defined $cxix;
2345 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2346              
2347             # if we're just beginning, do it all first
2348 0 0         if ($iter{$cxix} == 0) {
2349 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2350             }
2351              
2352             # chuck it all out, quick or slow
2353 0 0         if (wantarray) {
2354 0           delete $iter{$cxix};
2355 0           return @{delete $entries{$cxix}};
  0            
2356             }
2357             else {
2358 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2359 0           return shift @{$entries{$cxix}};
  0            
2360             }
2361             else {
2362             # return undef for EOL
2363 0           delete $iter{$cxix};
2364 0           delete $entries{$cxix};
2365 0           return undef;
2366             }
2367             }
2368             }
2369              
2370             #
2371             # Latin-3 path globbing subroutine
2372             #
2373             sub _do_glob {
2374              
2375 0     0     my($cond,@expr) = @_;
2376 0           my @glob = ();
2377 0           my $fix_drive_relative_paths = 0;
2378              
2379             OUTER:
2380 0           for my $expr (@expr) {
2381 0 0         next OUTER if not defined $expr;
2382 0 0         next OUTER if $expr eq '';
2383              
2384 0           my @matched = ();
2385 0           my @globdir = ();
2386 0           my $head = '.';
2387 0           my $pathsep = '/';
2388 0           my $tail;
2389              
2390             # if argument is within quotes strip em and do no globbing
2391 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2392 0           $expr = $1;
2393 0 0         if ($cond eq 'd') {
2394 0 0         if (-d $expr) {
2395 0           push @glob, $expr;
2396             }
2397             }
2398             else {
2399 0 0         if (-e $expr) {
2400 0           push @glob, $expr;
2401             }
2402             }
2403 0           next OUTER;
2404             }
2405              
2406             # wildcards with a drive prefix such as h:*.pm must be changed
2407             # to h:./*.pm to expand correctly
2408 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2409 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2410 0           $fix_drive_relative_paths = 1;
2411             }
2412             }
2413              
2414 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2415 0 0         if ($tail eq '') {
2416 0           push @glob, $expr;
2417 0           next OUTER;
2418             }
2419 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2420 0 0         if (@globdir = _do_glob('d', $head)) {
2421 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2422 0           next OUTER;
2423             }
2424             }
2425 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2426 0           $head .= $pathsep;
2427             }
2428 0           $expr = $tail;
2429             }
2430              
2431             # If file component has no wildcards, we can avoid opendir
2432 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2433 0 0         if ($head eq '.') {
2434 0           $head = '';
2435             }
2436 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2437 0           $head .= $pathsep;
2438             }
2439 0           $head .= $expr;
2440 0 0         if ($cond eq 'd') {
2441 0 0         if (-d $head) {
2442 0           push @glob, $head;
2443             }
2444             }
2445             else {
2446 0 0         if (-e $head) {
2447 0           push @glob, $head;
2448             }
2449             }
2450 0           next OUTER;
2451             }
2452 0 0         opendir(*DIR, $head) or next OUTER;
2453 0           my @leaf = readdir DIR;
2454 0           closedir DIR;
2455              
2456 0 0         if ($head eq '.') {
2457 0           $head = '';
2458             }
2459 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2460 0           $head .= $pathsep;
2461             }
2462              
2463 0           my $pattern = '';
2464 0           while ($expr =~ / \G ($q_char) /oxgc) {
2465 0           my $char = $1;
2466              
2467             # 6.9. Matching Shell Globs as Regular Expressions
2468             # in Chapter 6. Pattern Matching
2469             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2470             # (and so on)
2471              
2472 0 0         if ($char eq '*') {
    0          
    0          
2473 0           $pattern .= "(?:$your_char)*",
2474             }
2475             elsif ($char eq '?') {
2476 0           $pattern .= "(?:$your_char)?", # DOS style
2477             # $pattern .= "(?:$your_char)", # UNIX style
2478             }
2479             elsif ((my $fc = Char::Elatin3::fc($char)) ne $char) {
2480 0           $pattern .= $fc;
2481             }
2482             else {
2483 0           $pattern .= quotemeta $char;
2484             }
2485             }
2486 0     0     my $matchsub = sub { Char::Elatin3::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2487              
2488             # if ($@) {
2489             # print STDERR "$0: $@\n";
2490             # next OUTER;
2491             # }
2492              
2493             INNER:
2494 0           for my $leaf (@leaf) {
2495 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2496 0           next INNER;
2497             }
2498 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2499 0           next INNER;
2500             }
2501              
2502 0 0         if (&$matchsub($leaf)) {
2503 0           push @matched, "$head$leaf";
2504 0           next INNER;
2505             }
2506              
2507             # [DOS compatibility special case]
2508             # Failed, add a trailing dot and try again, but only...
2509              
2510 0 0 0       if (Char::Elatin3::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2511             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2512             Char::Elatin3::index($pattern,'\\.') != -1 # pattern has a dot.
2513             ) {
2514 0 0         if (&$matchsub("$leaf.")) {
2515 0           push @matched, "$head$leaf";
2516 0           next INNER;
2517             }
2518             }
2519             }
2520 0 0         if (@matched) {
2521 0           push @glob, @matched;
2522             }
2523             }
2524 0 0         if ($fix_drive_relative_paths) {
2525 0           for my $glob (@glob) {
2526 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2527             }
2528             }
2529 0           return @glob;
2530             }
2531              
2532             #
2533             # Latin-3 parse line
2534             #
2535             sub _parse_line {
2536              
2537 0     0     my($line) = @_;
2538              
2539 0           $line .= ' ';
2540 0           my @piece = ();
2541 0           while ($line =~ /
2542             " ( (?: [^"] )* ) " \s+ |
2543             ( (?: [^"\s] )* ) \s+
2544             /oxmsg
2545             ) {
2546 0 0         push @piece, defined($1) ? $1 : $2;
2547             }
2548 0           return @piece;
2549             }
2550              
2551             #
2552             # Latin-3 parse path
2553             #
2554             sub _parse_path {
2555              
2556 0     0     my($path,$pathsep) = @_;
2557              
2558 0           $path .= '/';
2559 0           my @subpath = ();
2560 0           while ($path =~ /
2561             ((?: [^\/\\] )+?) [\/\\]
2562             /oxmsg
2563             ) {
2564 0           push @subpath, $1;
2565             }
2566              
2567 0           my $tail = pop @subpath;
2568 0           my $head = join $pathsep, @subpath;
2569 0           return $head, $tail;
2570             }
2571              
2572             #
2573             # via File::HomeDir::Windows 1.00
2574             #
2575             sub my_home_MSWin32 {
2576              
2577             # A lot of unix people and unix-derived tools rely on
2578             # the ability to overload HOME. We will support it too
2579             # so that they can replace raw HOME calls with File::HomeDir.
2580 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2581 0           return $ENV{'HOME'};
2582             }
2583              
2584             # Do we have a user profile?
2585             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2586 0           return $ENV{'USERPROFILE'};
2587             }
2588              
2589             # Some Windows use something like $ENV{'HOME'}
2590             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2591 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2592             }
2593              
2594 0           return undef;
2595             }
2596              
2597             #
2598             # via File::HomeDir::Unix 1.00
2599             #
2600             sub my_home {
2601 0     0 0   my $home;
2602              
2603 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2604 0           $home = $ENV{'HOME'};
2605             }
2606              
2607             # This is from the original code, but I'm guessing
2608             # it means "login directory" and exists on some Unixes.
2609             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2610 0           $home = $ENV{'LOGDIR'};
2611             }
2612              
2613             ### More-desperate methods
2614              
2615             # Light desperation on any (Unixish) platform
2616             else {
2617 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2618             }
2619              
2620             # On Unix in general, a non-existant home means "no home"
2621             # For example, "nobody"-like users might use /nonexistant
2622 0 0 0       if (defined $home and ! -d($home)) {
2623 0           $home = undef;
2624             }
2625 0           return $home;
2626             }
2627              
2628             #
2629             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2630             #
2631             sub Char::Elatin3::PREMATCH {
2632 0     0 0   return $`;
2633             }
2634              
2635             #
2636             # ${^MATCH}, $MATCH, $& the string that matched
2637             #
2638             sub Char::Elatin3::MATCH {
2639 0     0 0   return $&;
2640             }
2641              
2642             #
2643             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2644             #
2645             sub Char::Elatin3::POSTMATCH {
2646 0     0 0   return $';
2647             }
2648              
2649             #
2650             # Latin-3 character to order (with parameter)
2651             #
2652             sub Char::Latin3::ord(;$) {
2653              
2654 0 0   0 1   local $_ = shift if @_;
2655              
2656 0 0         if (/\A ($q_char) /oxms) {
2657 0           my @ord = unpack 'C*', $1;
2658 0           my $ord = 0;
2659 0           while (my $o = shift @ord) {
2660 0           $ord = $ord * 0x100 + $o;
2661             }
2662 0           return $ord;
2663             }
2664             else {
2665 0           return CORE::ord $_;
2666             }
2667             }
2668              
2669             #
2670             # Latin-3 character to order (without parameter)
2671             #
2672             sub Char::Latin3::ord_() {
2673              
2674 0 0   0 0   if (/\A ($q_char) /oxms) {
2675 0           my @ord = unpack 'C*', $1;
2676 0           my $ord = 0;
2677 0           while (my $o = shift @ord) {
2678 0           $ord = $ord * 0x100 + $o;
2679             }
2680 0           return $ord;
2681             }
2682             else {
2683 0           return CORE::ord $_;
2684             }
2685             }
2686              
2687             #
2688             # Latin-3 reverse
2689             #
2690             sub Char::Latin3::reverse(@) {
2691              
2692 0 0   0 0   if (wantarray) {
2693 0           return CORE::reverse @_;
2694             }
2695             else {
2696              
2697             # One of us once cornered Larry in an elevator and asked him what
2698             # problem he was solving with this, but he looked as far off into
2699             # the distance as he could in an elevator and said, "It seemed like
2700             # a good idea at the time."
2701              
2702 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2703             }
2704             }
2705              
2706             #
2707             # Latin-3 getc (with parameter, without parameter)
2708             #
2709             sub Char::Latin3::getc(;*@) {
2710              
2711 0     0 0   my($package) = caller;
2712 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2713 0 0 0       croak 'Too many arguments for Char::Latin3::getc' if @_ and not wantarray;
2714              
2715 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2716 0           my $getc = '';
2717 0           for my $length ($length[0] .. $length[-1]) {
2718 0           $getc .= CORE::getc($fh);
2719 0 0         if (exists $range_tr{CORE::length($getc)}) {
2720 0 0         if ($getc =~ /\A ${Char::Elatin3::dot_s} \z/oxms) {
2721 0 0         return wantarray ? ($getc,@_) : $getc;
2722             }
2723             }
2724             }
2725 0 0         return wantarray ? ($getc,@_) : $getc;
2726             }
2727              
2728             #
2729             # Latin-3 length by character
2730             #
2731             sub Char::Latin3::length(;$) {
2732              
2733 0 0   0 1   local $_ = shift if @_;
2734              
2735 0           local @_ = /\G ($q_char) /oxmsg;
2736 0           return scalar @_;
2737             }
2738              
2739             #
2740             # Latin-3 substr by character
2741             #
2742             BEGIN {
2743              
2744             # P.232 The lvalue Attribute
2745             # in Chapter 6: Subroutines
2746             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2747              
2748             # P.336 The lvalue Attribute
2749             # in Chapter 7: Subroutines
2750             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2751              
2752             # P.144 8.4 Lvalue subroutines
2753             # in Chapter 8: perlsub: Perl subroutines
2754             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2755              
2756 197 50 0 197 1 190911 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            
2757             # vv----------------*******
2758             sub Char::Latin3::substr($$;$$) %s {
2759              
2760             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2761              
2762             # If the substring is beyond either end of the string, substr() returns the undefined
2763             # value and produces a warning. When used as an lvalue, specifying a substring that
2764             # is entirely outside the string raises an exception.
2765             # http://perldoc.perl.org/functions/substr.html
2766              
2767             # A return with no argument returns the scalar value undef in scalar context,
2768             # an empty list () in list context, and (naturally) nothing at all in void
2769             # context.
2770              
2771             my $offset = $_[1];
2772             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2773             return;
2774             }
2775              
2776             # substr($string,$offset,$length,$replacement)
2777             if (@_ == 4) {
2778             my(undef,undef,$length,$replacement) = @_;
2779             my $substr = join '', splice(@char, $offset, $length, $replacement);
2780             $_[0] = join '', @char;
2781              
2782             # return $substr; this doesn't work, don't say "return"
2783             $substr;
2784             }
2785              
2786             # substr($string,$offset,$length)
2787             elsif (@_ == 3) {
2788             my(undef,undef,$length) = @_;
2789             my $octet_offset = 0;
2790             my $octet_length = 0;
2791             if ($offset == 0) {
2792             $octet_offset = 0;
2793             }
2794             elsif ($offset > 0) {
2795             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2796             }
2797             else {
2798             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2799             }
2800             if ($length == 0) {
2801             $octet_length = 0;
2802             }
2803             elsif ($length > 0) {
2804             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2805             }
2806             else {
2807             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset, $octet_length);
2810             }
2811              
2812             # substr($string,$offset)
2813             else {
2814             my $octet_offset = 0;
2815             if ($offset == 0) {
2816             $octet_offset = 0;
2817             }
2818             elsif ($offset > 0) {
2819             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2820             }
2821             else {
2822             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2823             }
2824             CORE::substr($_[0], $octet_offset);
2825             }
2826             }
2827             END
2828             }
2829              
2830             #
2831             # Latin-3 index by character
2832             #
2833             sub Char::Latin3::index($$;$) {
2834              
2835 0     0 1   my $index;
2836 0 0         if (@_ == 3) {
2837 0           $index = Char::Elatin3::index($_[0], $_[1], CORE::length(Char::Latin3::substr($_[0], 0, $_[2])));
2838             }
2839             else {
2840 0           $index = Char::Elatin3::index($_[0], $_[1]);
2841             }
2842              
2843 0 0         if ($index == -1) {
2844 0           return -1;
2845             }
2846             else {
2847 0           return Char::Latin3::length(CORE::substr $_[0], 0, $index);
2848             }
2849             }
2850              
2851             #
2852             # Latin-3 rindex by character
2853             #
2854             sub Char::Latin3::rindex($$;$) {
2855              
2856 0     0 1   my $rindex;
2857 0 0         if (@_ == 3) {
2858 0           $rindex = Char::Elatin3::rindex($_[0], $_[1], CORE::length(Char::Latin3::substr($_[0], 0, $_[2])));
2859             }
2860             else {
2861 0           $rindex = Char::Elatin3::rindex($_[0], $_[1]);
2862             }
2863              
2864 0 0         if ($rindex == -1) {
2865 0           return -1;
2866             }
2867             else {
2868 0           return Char::Latin3::length(CORE::substr $_[0], 0, $rindex);
2869             }
2870             }
2871              
2872             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2873             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2874 197     197   17526 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  197     197   1982  
  197         413  
  197         22936  
2875              
2876             # ord() to ord() or Char::Latin3::ord()
2877 197     197   13392 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  197     197   1173  
  197         420  
  197         14356  
2878              
2879             # ord to ord or Char::Latin3::ord_
2880 197     197   12180 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  197     197   1139  
  197         386  
  197         18094  
2881              
2882             # reverse to reverse or Char::Latin3::reverse
2883 197     197   12497 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  197     197   1953  
  197         431  
  197         14574  
2884              
2885             # getc to getc or Char::Latin3::getc
2886 197     197   11703 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  197     197   1232  
  197         391  
  197         14258  
2887              
2888             # P.1023 Appendix W.9 Multibyte Anchoring
2889             # of ISBN 1-56592-224-7 CJKV Information Processing
2890              
2891             my $anchor = '';
2892              
2893 197     197   13395 BEGIN { CORE::eval q{ use vars qw($nest) } }
  197     197   1089  
  197         388  
  197         12541776  
2894              
2895             # regexp of nested parens in qqXX
2896              
2897             # P.340 Matching Nested Constructs with Embedded Code
2898             # in Chapter 7: Perl
2899             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2900              
2901             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2902             \\c[\x40-\x5F] |
2903             \\ [\x00-\xFF] |
2904             [^()] |
2905             \( (?{$nest++}) |
2906             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2907             }xms;
2908             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2909             \\c[\x40-\x5F] |
2910             \\ [\x00-\xFF] |
2911             [^{}] |
2912             \{ (?{$nest++}) |
2913             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2914             }xms;
2915             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2916             \\c[\x40-\x5F] |
2917             \\ [\x00-\xFF] |
2918             [^[\]] |
2919             \[ (?{$nest++}) |
2920             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2921             }xms;
2922             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2923             \\c[\x40-\x5F] |
2924             \\ [\x00-\xFF] |
2925             [^<>] |
2926             \< (?{$nest++}) |
2927             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2928             }xms;
2929             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2930             (?: ::)? (?:
2931             [a-zA-Z_][a-zA-Z_0-9]*
2932             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2933             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2934             ))
2935             }xms;
2936             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2937             (?: ::)? (?:
2938             [0-9]+ |
2939             [^a-zA-Z_0-9\[\]] |
2940             ^[A-Z] |
2941             [a-zA-Z_][a-zA-Z_0-9]*
2942             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2943             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2944             ))
2945             }xms;
2946             my $qq_substr = qr{(?: Char::Latin3::substr | CORE::substr | substr ) \( $qq_paren \)
2947             }xms;
2948              
2949             # regexp of nested parens in qXX
2950             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2951             [^()] |
2952             \( (?{$nest++}) |
2953             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2954             }xms;
2955             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2956             [^{}] |
2957             \{ (?{$nest++}) |
2958             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2959             }xms;
2960             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2961             [^[\]] |
2962             \[ (?{$nest++}) |
2963             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2964             }xms;
2965             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2966             [^<>] |
2967             \< (?{$nest++}) |
2968             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2969             }xms;
2970              
2971             my $matched = '';
2972             my $s_matched = '';
2973              
2974             my $tr_variable = ''; # variable of tr///
2975             my $sub_variable = ''; # variable of s///
2976             my $bind_operator = ''; # =~ or !~
2977              
2978             my @heredoc = (); # here document
2979             my @heredoc_delimiter = ();
2980             my $here_script = ''; # here script
2981              
2982             #
2983             # escape Latin-3 script
2984             #
2985             sub Char::Latin3::escape(;$) {
2986 0 0   0 0   local($_) = $_[0] if @_;
2987              
2988             # P.359 The Study Function
2989             # in Chapter 7: Perl
2990             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2991              
2992 0           study $_; # Yes, I studied study yesterday.
2993              
2994             # while all script
2995              
2996             # 6.14. Matching from Where the Last Pattern Left Off
2997             # in Chapter 6. Pattern Matching
2998             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2999             # (and so on)
3000              
3001             # one member of Tag-team
3002             #
3003             # P.128 Start of match (or end of previous match): \G
3004             # P.130 Advanced Use of \G with Perl
3005             # in Chapter 3: Overview of Regular Expression Features and Flavors
3006             # P.255 Use leading anchors
3007             # P.256 Expose ^ and \G at the front expressions
3008             # in Chapter 6: Crafting an Efficient Expression
3009             # P.315 "Tag-team" matching with /gc
3010             # in Chapter 7: Perl
3011             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3012              
3013 0           my $e_script = '';
3014 0           while (not /\G \z/oxgc) { # member
3015 0           $e_script .= Char::Latin3::escape_token();
3016             }
3017              
3018 0           return $e_script;
3019             }
3020              
3021             #
3022             # escape Latin-3 token of script
3023             #
3024             sub Char::Latin3::escape_token {
3025              
3026             # \n output here document
3027              
3028 0     0 0   my $ignore_modules = join('|', qw(
3029             utf8
3030             bytes
3031             charnames
3032             I18N::Japanese
3033             I18N::Collate
3034             I18N::JExt
3035             File::DosGlob
3036             Wild
3037             Wildcard
3038             Japanese
3039             ));
3040              
3041             # another member of Tag-team
3042             #
3043             # P.315 "Tag-team" matching with /gc
3044             # in Chapter 7: Perl
3045             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3046              
3047 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          
3048 0           my $heredoc = '';
3049 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3050 0           $slash = 'm//';
3051              
3052 0           $heredoc = join '', @heredoc;
3053 0           @heredoc = ();
3054              
3055             # skip here document
3056 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3057 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3058             }
3059 0           @heredoc_delimiter = ();
3060              
3061 0           $here_script = '';
3062             }
3063 0           return "\n" . $heredoc;
3064             }
3065              
3066             # ignore space, comment
3067 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
3068              
3069             # if (, elsif (, unless (, while (, until (, given (, and when (
3070              
3071             # given, when
3072              
3073             # P.225 The given Statement
3074             # in Chapter 15: Smart Matching and given-when
3075             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3076              
3077             # P.133 The given Statement
3078             # in Chapter 4: Statements and Declarations
3079             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3080              
3081             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
3082 0           $slash = 'm//';
3083 0           return $1;
3084             }
3085              
3086             # scalar variable ($scalar = ...) =~ tr///;
3087             # scalar variable ($scalar = ...) =~ s///;
3088              
3089             # state
3090              
3091             # P.68 Persistent, Private Variables
3092             # in Chapter 4: Subroutines
3093             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3094              
3095             # P.160 Persistent Lexically Scoped Variables: state
3096             # in Chapter 4: Statements and Declarations
3097             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3098              
3099             # (and so on)
3100              
3101             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
3102 0           my $e_string = e_string($1);
3103              
3104 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3105 0           $tr_variable = $e_string . e_string($1);
3106 0           $bind_operator = $2;
3107 0           $slash = 'm//';
3108 0           return '';
3109             }
3110             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3111 0           $sub_variable = $e_string . e_string($1);
3112 0           $bind_operator = $2;
3113 0           $slash = 'm//';
3114 0           return '';
3115             }
3116             else {
3117 0           $slash = 'div';
3118 0           return $e_string;
3119             }
3120             }
3121              
3122             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin3::PREMATCH()
3123             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
3124 0           $slash = 'div';
3125 0           return q{Char::Elatin3::PREMATCH()};
3126             }
3127              
3128             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin3::MATCH()
3129             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
3130 0           $slash = 'div';
3131 0           return q{Char::Elatin3::MATCH()};
3132             }
3133              
3134             # $', ${'} --> $', ${'}
3135             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3136 0           $slash = 'div';
3137 0           return $1;
3138             }
3139              
3140             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin3::POSTMATCH()
3141             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
3142 0           $slash = 'div';
3143 0           return q{Char::Elatin3::POSTMATCH()};
3144             }
3145              
3146             # scalar variable $scalar =~ tr///;
3147             # scalar variable $scalar =~ s///;
3148             # substr() =~ tr///;
3149             # substr() =~ s///;
3150             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3151 0           my $scalar = e_string($1);
3152              
3153 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3154 0           $tr_variable = $scalar;
3155 0           $bind_operator = $1;
3156 0           $slash = 'm//';
3157 0           return '';
3158             }
3159             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3160 0           $sub_variable = $scalar;
3161 0           $bind_operator = $1;
3162 0           $slash = 'm//';
3163 0           return '';
3164             }
3165             else {
3166 0           $slash = 'div';
3167 0           return $scalar;
3168             }
3169             }
3170              
3171             # end of statement
3172             elsif (/\G ( [,;] ) /oxgc) {
3173 0           $slash = 'm//';
3174              
3175             # clear tr/// variable
3176 0           $tr_variable = '';
3177              
3178             # clear s/// variable
3179 0           $sub_variable = '';
3180              
3181 0           $bind_operator = '';
3182              
3183 0           return $1;
3184             }
3185              
3186             # bareword
3187             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
3188 0           return $1;
3189             }
3190              
3191             # $0 --> $0
3192             elsif (/\G ( \$ 0 ) /oxmsgc) {
3193 0           $slash = 'div';
3194 0           return $1;
3195             }
3196             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
3197 0           $slash = 'div';
3198 0           return $1;
3199             }
3200              
3201             # $$ --> $$
3202             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3203 0           $slash = 'div';
3204 0           return $1;
3205             }
3206              
3207             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3208             # $1, $2, $3 --> $1, $2, $3 otherwise
3209             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
3210 0           $slash = 'div';
3211 0           return e_capture($1);
3212             }
3213             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
3214 0           $slash = 'div';
3215 0           return e_capture($1);
3216             }
3217              
3218             # $$foo[ ... ] --> $ $foo->[ ... ]
3219             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
3220 0           $slash = 'div';
3221 0           return e_capture($1.'->'.$2);
3222             }
3223              
3224             # $$foo{ ... } --> $ $foo->{ ... }
3225             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
3226 0           $slash = 'div';
3227 0           return e_capture($1.'->'.$2);
3228             }
3229              
3230             # $$foo
3231             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
3232 0           $slash = 'div';
3233 0           return e_capture($1);
3234             }
3235              
3236             # ${ foo }
3237             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
3238 0           $slash = 'div';
3239 0           return '${' . $1 . '}';
3240             }
3241              
3242             # ${ ... }
3243             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
3244 0           $slash = 'div';
3245 0           return e_capture($1);
3246             }
3247              
3248             # variable or function
3249             # $ @ % & * $ #
3250             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) {
3251 0           $slash = 'div';
3252 0           return $1;
3253             }
3254             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3255             # $ @ # \ ' " / ? ( ) [ ] < >
3256             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3257 0           $slash = 'div';
3258 0           return $1;
3259             }
3260              
3261             # while ()
3262             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
3263 0           return $1;
3264             }
3265              
3266             # while () --- glob
3267              
3268             # avoid "Error: Runtime exception" of perl version 5.005_03
3269              
3270             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
3271 0           return 'while ($_ = Char::Elatin3::glob("' . $1 . '"))';
3272             }
3273              
3274             # while (glob)
3275             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
3276 0           return 'while ($_ = Char::Elatin3::glob_)';
3277             }
3278              
3279             # while (glob(WILDCARD))
3280             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
3281 0           return 'while ($_ = Char::Elatin3::glob';
3282             }
3283              
3284             # doit if, doit unless, doit while, doit until, doit for, doit when
3285 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3286              
3287             # subroutines of package Char::Elatin3
3288 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3289 0           elsif (/\G \b Char::Latin3::eval (?= \s* \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3290 0           elsif (/\G \b Char::Latin3::eval \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'eval Char::Latin3::escape'; }
  0            
3291 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3292 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::chop'; }
  0            
3293 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3294 0           elsif (/\G \b Char::Latin3::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin3::index'; }
  0            
3295 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::index'; }
  0            
3296 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3297 0           elsif (/\G \b Char::Latin3::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin3::rindex'; }
  0            
3298 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::rindex'; }
  0            
3299 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::lc'; }
  0            
3300 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::lcfirst'; }
  0            
3301 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::uc'; }
  0            
3302 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::ucfirst'; }
  0            
3303 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::fc'; }
  0            
3304              
3305             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3306 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3307 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3308 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3309 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3310 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3311 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3312 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3313              
3314 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3315 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3316 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3317 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3318 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3319 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3320 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3321              
3322             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3323 0           { $slash = 'm//'; return "-s $1"; }
  0            
3324 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3325 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3326 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3327              
3328 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3329 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3330 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::chr'; }
  0            
3331 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3332 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3333 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::glob'; }
  0            
3334 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::lc_'; }
  0            
3335 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::lcfirst_'; }
  0            
3336 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::uc_'; }
  0            
3337 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::ucfirst_'; }
  0            
3338 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::fc_'; }
  0            
3339 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3340              
3341 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3342 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3343 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::chr_'; }
  0            
3344 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3345 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3346 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin3::glob_'; }
  0            
3347 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3348 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3349             # split
3350             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
3351 0           $slash = 'm//';
3352              
3353 0           my $e = '';
3354 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
3355 0           $e .= $1;
3356             }
3357              
3358             # end of split
3359 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin3::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          
3360              
3361             # split scalar value
3362 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Elatin3::split' . $e . e_string($1); }
3363              
3364             # split literal space
3365 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Elatin3::split' . $e . qq {qq$1 $2}; }
3366 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; }
3367 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; }
3368 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; }
3369 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; }
3370 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; }
3371 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Elatin3::split' . $e . qq {q$1 $2}; }
3372 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; }
3373 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; }
3374 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; }
3375 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; }
3376 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; }
3377 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Elatin3::split' . $e . qq {' '}; }
3378 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Elatin3::split' . $e . qq {" "}; }
3379              
3380             # split qq//
3381             elsif (/\G \b (qq) \b /oxgc) {
3382 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3383             else {
3384 0           while (not /\G \z/oxgc) {
3385 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3386 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3387 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3388 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3389 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3390 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3391 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3392             }
3393 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3394             }
3395             }
3396              
3397             # split qr//
3398             elsif (/\G \b (qr) \b /oxgc) {
3399 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3400             else {
3401 0           while (not /\G \z/oxgc) {
3402 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3403 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3404 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3405 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3406 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3407 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3408 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3409 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3410             }
3411 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3412             }
3413             }
3414              
3415             # split q//
3416             elsif (/\G \b (q) \b /oxgc) {
3417 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3418             else {
3419 0           while (not /\G \z/oxgc) {
3420 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3421 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3422 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3423 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3424 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3425 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3426 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3427             }
3428 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3429             }
3430             }
3431              
3432             # split m//
3433             elsif (/\G \b (m) \b /oxgc) {
3434 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3435             else {
3436 0           while (not /\G \z/oxgc) {
3437 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3438 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3439 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3440 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3441 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3442 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3443 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3444 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3445             }
3446 0           die __FILE__, ": Search pattern not terminated";
3447             }
3448             }
3449              
3450             # split ''
3451             elsif (/\G (\') /oxgc) {
3452 0           my $q_string = '';
3453 0           while (not /\G \z/oxgc) {
3454 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3455 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3456 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3457 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3458             }
3459 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3460             }
3461              
3462             # split ""
3463             elsif (/\G (\") /oxgc) {
3464 0           my $qq_string = '';
3465 0           while (not /\G \z/oxgc) {
3466 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3467 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3468 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3469 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3470             }
3471 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3472             }
3473              
3474             # split //
3475             elsif (/\G (\/) /oxgc) {
3476 0           my $regexp = '';
3477 0           while (not /\G \z/oxgc) {
3478 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3479 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3480 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3481 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3482             }
3483 0           die __FILE__, ": Search pattern not terminated";
3484             }
3485             }
3486              
3487             # tr/// or y///
3488              
3489             # about [cdsrbB]* (/B modifier)
3490             #
3491             # P.559 appendix C
3492             # of ISBN 4-89052-384-7 Programming perl
3493             # (Japanese title is: Perl puroguramingu)
3494              
3495             elsif (/\G \b ( tr | y ) \b /oxgc) {
3496 0           my $ope = $1;
3497              
3498             # $1 $2 $3 $4 $5 $6
3499 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3500 0           my @tr = ($tr_variable,$2);
3501 0           return e_tr(@tr,'',$4,$6);
3502             }
3503             else {
3504 0           my $e = '';
3505 0           while (not /\G \z/oxgc) {
3506 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3507             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3508 0           my @tr = ($tr_variable,$2);
3509 0           while (not /\G \z/oxgc) {
3510 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3511 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3512 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3513 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3514 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3515 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3516             }
3517 0           die __FILE__, ": Transliteration replacement not terminated";
3518             }
3519             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3520 0           my @tr = ($tr_variable,$2);
3521 0           while (not /\G \z/oxgc) {
3522 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3523 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3524 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3525 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3526 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3527 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3528             }
3529 0           die __FILE__, ": Transliteration replacement not terminated";
3530             }
3531             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3532 0           my @tr = ($tr_variable,$2);
3533 0           while (not /\G \z/oxgc) {
3534 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3535 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3536 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3537 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3538 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3539 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3540             }
3541 0           die __FILE__, ": Transliteration replacement not terminated";
3542             }
3543             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3544 0           my @tr = ($tr_variable,$2);
3545 0           while (not /\G \z/oxgc) {
3546 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3547 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3548 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3549 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3550 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3551 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3552             }
3553 0           die __FILE__, ": Transliteration replacement not terminated";
3554             }
3555             # $1 $2 $3 $4 $5 $6
3556             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3557 0           my @tr = ($tr_variable,$2);
3558 0           return e_tr(@tr,'',$4,$6);
3559             }
3560             }
3561 0           die __FILE__, ": Transliteration pattern not terminated";
3562             }
3563             }
3564              
3565             # qq//
3566             elsif (/\G \b (qq) \b /oxgc) {
3567 0           my $ope = $1;
3568              
3569             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3570 0 0         if (/\G (\#) /oxgc) { # qq# #
3571 0           my $qq_string = '';
3572 0           while (not /\G \z/oxgc) {
3573 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3574 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3575 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3576 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3577             }
3578 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3579             }
3580              
3581             else {
3582 0           my $e = '';
3583 0           while (not /\G \z/oxgc) {
3584 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3585              
3586             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3587             elsif (/\G (\() /oxgc) { # qq ( )
3588 0           my $qq_string = '';
3589 0           local $nest = 1;
3590 0           while (not /\G \z/oxgc) {
3591 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3592 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3593 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3594             elsif (/\G (\)) /oxgc) {
3595 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3596 0           else { $qq_string .= $1; }
3597             }
3598 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3599             }
3600 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3601             }
3602              
3603             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3604             elsif (/\G (\{) /oxgc) { # qq { }
3605 0           my $qq_string = '';
3606 0           local $nest = 1;
3607 0           while (not /\G \z/oxgc) {
3608 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3609 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3610 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3611             elsif (/\G (\}) /oxgc) {
3612 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3613 0           else { $qq_string .= $1; }
3614             }
3615 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3616             }
3617 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3618             }
3619              
3620             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3621             elsif (/\G (\[) /oxgc) { # qq [ ]
3622 0           my $qq_string = '';
3623 0           local $nest = 1;
3624 0           while (not /\G \z/oxgc) {
3625 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3626 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3627 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3628             elsif (/\G (\]) /oxgc) {
3629 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3630 0           else { $qq_string .= $1; }
3631             }
3632 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3633             }
3634 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3635             }
3636              
3637             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3638             elsif (/\G (\<) /oxgc) { # qq < >
3639 0           my $qq_string = '';
3640 0           local $nest = 1;
3641 0           while (not /\G \z/oxgc) {
3642 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3643 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3644 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3645             elsif (/\G (\>) /oxgc) {
3646 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3647 0           else { $qq_string .= $1; }
3648             }
3649 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3650             }
3651 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3652             }
3653              
3654             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3655             elsif (/\G (\S) /oxgc) { # qq * *
3656 0           my $delimiter = $1;
3657 0           my $qq_string = '';
3658 0           while (not /\G \z/oxgc) {
3659 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3660 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3661 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3662 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3663             }
3664 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3665             }
3666             }
3667 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3668             }
3669             }
3670              
3671             # qr//
3672             elsif (/\G \b (qr) \b /oxgc) {
3673 0           my $ope = $1;
3674 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
3675 0           return e_qr($ope,$1,$3,$2,$4);
3676             }
3677             else {
3678 0           my $e = '';
3679 0           while (not /\G \z/oxgc) {
3680 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3681 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3682 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3683 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3684 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3685 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3686 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3687 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3688             }
3689 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3690             }
3691             }
3692              
3693             # qw//
3694             elsif (/\G \b (qw) \b /oxgc) {
3695 0           my $ope = $1;
3696 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3697 0           return e_qw($ope,$1,$3,$2);
3698             }
3699             else {
3700 0           my $e = '';
3701 0           while (not /\G \z/oxgc) {
3702 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3703              
3704 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3705 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3706              
3707 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3708 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3709              
3710 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3711 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3712              
3713 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3714 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3715              
3716 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3717 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3718             }
3719 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3720             }
3721             }
3722              
3723             # qx//
3724             elsif (/\G \b (qx) \b /oxgc) {
3725 0           my $ope = $1;
3726 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3727 0           return e_qq($ope,$1,$3,$2);
3728             }
3729             else {
3730 0           my $e = '';
3731 0           while (not /\G \z/oxgc) {
3732 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3733 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3734 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3735 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3736 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3737 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3738 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3739             }
3740 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3741             }
3742             }
3743              
3744             # q//
3745             elsif (/\G \b (q) \b /oxgc) {
3746 0           my $ope = $1;
3747              
3748             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3749              
3750             # avoid "Error: Runtime exception" of perl version 5.005_03
3751             # (and so on)
3752              
3753 0 0         if (/\G (\#) /oxgc) { # q# #
3754 0           my $q_string = '';
3755 0           while (not /\G \z/oxgc) {
3756 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3757 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3758 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3759 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3760             }
3761 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3762             }
3763              
3764             else {
3765 0           my $e = '';
3766 0           while (not /\G \z/oxgc) {
3767 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3768              
3769             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3770             elsif (/\G (\() /oxgc) { # q ( )
3771 0           my $q_string = '';
3772 0           local $nest = 1;
3773 0           while (not /\G \z/oxgc) {
3774 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3775 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3776 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3777 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3778             elsif (/\G (\)) /oxgc) {
3779 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3780 0           else { $q_string .= $1; }
3781             }
3782 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3783             }
3784 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3785             }
3786              
3787             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3788             elsif (/\G (\{) /oxgc) { # q { }
3789 0           my $q_string = '';
3790 0           local $nest = 1;
3791 0           while (not /\G \z/oxgc) {
3792 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3793 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3794 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3795 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3796             elsif (/\G (\}) /oxgc) {
3797 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3798 0           else { $q_string .= $1; }
3799             }
3800 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3801             }
3802 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3803             }
3804              
3805             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3806             elsif (/\G (\[) /oxgc) { # q [ ]
3807 0           my $q_string = '';
3808 0           local $nest = 1;
3809 0           while (not /\G \z/oxgc) {
3810 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3811 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3812 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3813 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3814             elsif (/\G (\]) /oxgc) {
3815 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3816 0           else { $q_string .= $1; }
3817             }
3818 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3819             }
3820 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3821             }
3822              
3823             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3824             elsif (/\G (\<) /oxgc) { # q < >
3825 0           my $q_string = '';
3826 0           local $nest = 1;
3827 0           while (not /\G \z/oxgc) {
3828 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3829 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3830 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3831 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3832             elsif (/\G (\>) /oxgc) {
3833 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3834 0           else { $q_string .= $1; }
3835             }
3836 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3837             }
3838 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3839             }
3840              
3841             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3842             elsif (/\G (\S) /oxgc) { # q * *
3843 0           my $delimiter = $1;
3844 0           my $q_string = '';
3845 0           while (not /\G \z/oxgc) {
3846 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3847 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3848 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3849 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3850             }
3851 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3852             }
3853             }
3854 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3855             }
3856             }
3857              
3858             # m//
3859             elsif (/\G \b (m) \b /oxgc) {
3860 0           my $ope = $1;
3861 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
3862 0           return e_qr($ope,$1,$3,$2,$4);
3863             }
3864             else {
3865 0           my $e = '';
3866 0           while (not /\G \z/oxgc) {
3867 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3868 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3869 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3870 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3871 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3872 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3873 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3874 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3875 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3876             }
3877 0           die __FILE__, ": Search pattern not terminated";
3878             }
3879             }
3880              
3881             # s///
3882              
3883             # about [cegimosxpradlubB]* (/cg modifier)
3884             #
3885             # P.67 Pattern-Matching Operators
3886             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3887              
3888             elsif (/\G \b (s) \b /oxgc) {
3889 0           my $ope = $1;
3890              
3891             # $1 $2 $3 $4 $5 $6
3892 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
3893 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3894             }
3895             else {
3896 0           my $e = '';
3897 0           while (not /\G \z/oxgc) {
3898 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3899             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3900 0           my @s = ($1,$2,$3);
3901 0           while (not /\G \z/oxgc) {
3902 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3903             # $1 $2 $3 $4
3904 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3905 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3906 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3907 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3908 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3909 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([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 (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913             }
3914 0           die __FILE__, ": Substitution replacement not terminated";
3915             }
3916             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3917 0           my @s = ($1,$2,$3);
3918 0           while (not /\G \z/oxgc) {
3919 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3920             # $1 $2 $3 $4
3921 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3922 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3923 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0           elsif (/\G (\:) ((?:$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_bracket)*?) (\]) /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          
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 (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945             }
3946 0           die __FILE__, ": Substitution replacement not terminated";
3947             }
3948             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3949 0           my @s = ($1,$2,$3);
3950 0           while (not /\G \z/oxgc) {
3951 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3952             # $1 $2 $3 $4
3953 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3954 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3955 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3956 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962             }
3963 0           die __FILE__, ": Substitution replacement not terminated";
3964             }
3965             # $1 $2 $3 $4 $5 $6
3966             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
3967 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3968             }
3969             # $1 $2 $3 $4 $5 $6
3970             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3971 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3972             }
3973             # $1 $2 $3 $4 $5 $6
3974             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3975 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3976             }
3977             # $1 $2 $3 $4 $5 $6
3978             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3979 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3980             }
3981             }
3982 0           die __FILE__, ": Substitution pattern not terminated";
3983             }
3984             }
3985              
3986             # require ignore module
3987 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3988 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3989 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3990              
3991             # use strict; --> use strict; no strict qw(refs);
3992 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3993 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3994 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3995              
3996             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
3997             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3998 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
3999 0           return "use $1; no strict qw(refs);";
4000             }
4001             else {
4002 0           return "use $1;";
4003             }
4004             }
4005             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
4006 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4007 0           return "use $1; no strict qw(refs);";
4008             }
4009             else {
4010 0           return "use $1;";
4011             }
4012             }
4013              
4014             # ignore use module
4015 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4016 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4017 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4018              
4019             # ignore no module
4020 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4021 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4022 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4023              
4024             # use else
4025 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4026              
4027             # use else
4028 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4029              
4030             # ''
4031             elsif (/\G (?
4032 0           my $q_string = '';
4033 0           while (not /\G \z/oxgc) {
4034 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4035 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4036 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4037 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4038             }
4039 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4040             }
4041              
4042             # ""
4043             elsif (/\G (\") /oxgc) {
4044 0           my $qq_string = '';
4045 0           while (not /\G \z/oxgc) {
4046 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4047 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4048 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4049 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4050             }
4051 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4052             }
4053              
4054             # ``
4055             elsif (/\G (\`) /oxgc) {
4056 0           my $qx_string = '';
4057 0           while (not /\G \z/oxgc) {
4058 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4059 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4060 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4061 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4062             }
4063 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4064             }
4065              
4066             # // --- not divide operator (num / num), not defined-or
4067             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4068 0           my $regexp = '';
4069 0           while (not /\G \z/oxgc) {
4070 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4071 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4072 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4073 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4074             }
4075 0           die __FILE__, ": Search pattern not terminated";
4076             }
4077              
4078             # ?? --- not conditional operator (condition ? then : else)
4079             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4080 0           my $regexp = '';
4081 0           while (not /\G \z/oxgc) {
4082 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4083 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4084 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4085 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4086             }
4087 0           die __FILE__, ": Search pattern not terminated";
4088             }
4089              
4090             # << (bit shift) --- not here document
4091 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4092              
4093             # <<'HEREDOC'
4094             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4095 0           $slash = 'm//';
4096 0           my $here_quote = $1;
4097 0           my $delimiter = $2;
4098              
4099             # get here document
4100 0 0         if ($here_script eq '') {
4101 0           $here_script = CORE::substr $_, pos $_;
4102 0           $here_script =~ s/.*?\n//oxm;
4103             }
4104 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4105 0           push @heredoc, $1 . qq{\n$delimiter\n};
4106 0           push @heredoc_delimiter, $delimiter;
4107             }
4108             else {
4109 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4110             }
4111 0           return $here_quote;
4112             }
4113              
4114             # <<\HEREDOC
4115              
4116             # P.66 2.6.6. "Here" Documents
4117             # in Chapter 2: Bits and Pieces
4118             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4119              
4120             # P.73 "Here" Documents
4121             # in Chapter 2: Bits and Pieces
4122             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4123              
4124             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4125 0           $slash = 'm//';
4126 0           my $here_quote = $1;
4127 0           my $delimiter = $2;
4128              
4129             # get here document
4130 0 0         if ($here_script eq '') {
4131 0           $here_script = CORE::substr $_, pos $_;
4132 0           $here_script =~ s/.*?\n//oxm;
4133             }
4134 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4135 0           push @heredoc, $1 . qq{\n$delimiter\n};
4136 0           push @heredoc_delimiter, $delimiter;
4137             }
4138             else {
4139 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4140             }
4141 0           return $here_quote;
4142             }
4143              
4144             # <<"HEREDOC"
4145             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4146 0           $slash = 'm//';
4147 0           my $here_quote = $1;
4148 0           my $delimiter = $2;
4149              
4150             # get here document
4151 0 0         if ($here_script eq '') {
4152 0           $here_script = CORE::substr $_, pos $_;
4153 0           $here_script =~ s/.*?\n//oxm;
4154             }
4155 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4156 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4157 0           push @heredoc_delimiter, $delimiter;
4158             }
4159             else {
4160 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4161             }
4162 0           return $here_quote;
4163             }
4164              
4165             # <
4166             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4167 0           $slash = 'm//';
4168 0           my $here_quote = $1;
4169 0           my $delimiter = $2;
4170              
4171             # get here document
4172 0 0         if ($here_script eq '') {
4173 0           $here_script = CORE::substr $_, pos $_;
4174 0           $here_script =~ s/.*?\n//oxm;
4175             }
4176 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4177 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4178 0           push @heredoc_delimiter, $delimiter;
4179             }
4180             else {
4181 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4182             }
4183 0           return $here_quote;
4184             }
4185              
4186             # <<`HEREDOC`
4187             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4188 0           $slash = 'm//';
4189 0           my $here_quote = $1;
4190 0           my $delimiter = $2;
4191              
4192             # get here document
4193 0 0         if ($here_script eq '') {
4194 0           $here_script = CORE::substr $_, pos $_;
4195 0           $here_script =~ s/.*?\n//oxm;
4196             }
4197 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4198 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4199 0           push @heredoc_delimiter, $delimiter;
4200             }
4201             else {
4202 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4203             }
4204 0           return $here_quote;
4205             }
4206              
4207             # <<= <=> <= < operator
4208             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4209 0           return $1;
4210             }
4211              
4212             #
4213             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4214 0           return $1;
4215             }
4216              
4217             # --- glob
4218              
4219             # avoid "Error: Runtime exception" of perl version 5.005_03
4220              
4221             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4222 0           return 'Char::Elatin3::glob("' . $1 . '")';
4223             }
4224              
4225             # __DATA__
4226 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4227              
4228             # __END__
4229 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4230              
4231             # \cD Control-D
4232              
4233             # P.68 2.6.8. Other Literal Tokens
4234             # in Chapter 2: Bits and Pieces
4235             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4236              
4237             # P.76 Other Literal Tokens
4238             # in Chapter 2: Bits and Pieces
4239             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4240              
4241 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4242              
4243             # \cZ Control-Z
4244 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4245              
4246             # any operator before div
4247             elsif (/\G (
4248             -- | \+\+ |
4249             [\)\}\]]
4250              
4251 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4252              
4253             # yada-yada or triple-dot operator
4254             elsif (/\G (
4255             \.\.\.
4256              
4257 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4258              
4259             # any operator before m//
4260              
4261             # //, //= (defined-or)
4262              
4263             # P.164 Logical Operators
4264             # in Chapter 10: More Control Structures
4265             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4266              
4267             # P.119 C-Style Logical (Short-Circuit) Operators
4268             # in Chapter 3: Unary and Binary Operators
4269             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4270              
4271             # (and so on)
4272              
4273             # ~~
4274              
4275             # P.221 The Smart Match Operator
4276             # in Chapter 15: Smart Matching and given-when
4277             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4278              
4279             # P.112 Smartmatch Operator
4280             # in Chapter 3: Unary and Binary Operators
4281             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4282              
4283             # (and so on)
4284              
4285             elsif (/\G (
4286              
4287             !~~ | !~ | != | ! |
4288             %= | % |
4289             &&= | && | &= | & |
4290             -= | -> | - |
4291             :\s*= |
4292             : |
4293             <<= | <=> | <= | < |
4294             == | => | =~ | = |
4295             >>= | >> | >= | > |
4296             \*\*= | \*\* | \*= | \* |
4297             \+= | \+ |
4298             \.\. | \.= | \. |
4299             \/\/= | \/\/ |
4300             \/= | \/ |
4301             \? |
4302             \\ |
4303             \^= | \^ |
4304             \b x= |
4305             \|\|= | \|\| | \|= | \| |
4306             ~~ | ~ |
4307             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4308             \b(?: print )\b |
4309              
4310             [,;\(\{\[]
4311              
4312 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4313              
4314             # other any character
4315 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4316              
4317             # system error
4318             else {
4319 0           die __FILE__, ": Oops, this shouldn't happen!";
4320             }
4321             }
4322              
4323             # escape Latin-3 string
4324             sub e_string {
4325 0     0 0   my($string) = @_;
4326 0           my $e_string = '';
4327              
4328 0           local $slash = 'm//';
4329              
4330             # P.1024 Appendix W.10 Multibyte Processing
4331             # of ISBN 1-56592-224-7 CJKV Information Processing
4332             # (and so on)
4333              
4334 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
4335              
4336             # without { ... }
4337 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4338 0 0         if ($string !~ /<
4339 0           return $string;
4340             }
4341             }
4342              
4343             E_STRING_LOOP:
4344 0           while ($string !~ /\G \z/oxgc) {
4345 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          
4346             }
4347              
4348             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Elatin3::PREMATCH()]}
4349 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
4350 0           $e_string .= q{Char::Elatin3::PREMATCH()};
4351 0           $slash = 'div';
4352             }
4353              
4354             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Elatin3::MATCH()]}
4355             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
4356 0           $e_string .= q{Char::Elatin3::MATCH()};
4357 0           $slash = 'div';
4358             }
4359              
4360             # $', ${'} --> $', ${'}
4361             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4362 0           $e_string .= $1;
4363 0           $slash = 'div';
4364             }
4365              
4366             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Elatin3::POSTMATCH()]}
4367             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
4368 0           $e_string .= q{Char::Elatin3::POSTMATCH()};
4369 0           $slash = 'div';
4370             }
4371              
4372             # bareword
4373             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
4374 0           $e_string .= $1;
4375 0           $slash = 'div';
4376             }
4377              
4378             # $0 --> $0
4379             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4380 0           $e_string .= $1;
4381 0           $slash = 'div';
4382             }
4383             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
4384 0           $e_string .= $1;
4385 0           $slash = 'div';
4386             }
4387              
4388             # $$ --> $$
4389             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4390 0           $e_string .= $1;
4391 0           $slash = 'div';
4392             }
4393              
4394             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4395             # $1, $2, $3 --> $1, $2, $3 otherwise
4396             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
4397 0           $e_string .= e_capture($1);
4398 0           $slash = 'div';
4399             }
4400             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
4401 0           $e_string .= e_capture($1);
4402 0           $slash = 'div';
4403             }
4404              
4405             # $$foo[ ... ] --> $ $foo->[ ... ]
4406             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
4407 0           $e_string .= e_capture($1.'->'.$2);
4408 0           $slash = 'div';
4409             }
4410              
4411             # $$foo{ ... } --> $ $foo->{ ... }
4412             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
4413 0           $e_string .= e_capture($1.'->'.$2);
4414 0           $slash = 'div';
4415             }
4416              
4417             # $$foo
4418             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
4419 0           $e_string .= e_capture($1);
4420 0           $slash = 'div';
4421             }
4422              
4423             # ${ foo }
4424             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
4425 0           $e_string .= '${' . $1 . '}';
4426 0           $slash = 'div';
4427             }
4428              
4429             # ${ ... }
4430             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
4431 0           $e_string .= e_capture($1);
4432 0           $slash = 'div';
4433             }
4434              
4435             # variable or function
4436             # $ @ % & * $ #
4437             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) {
4438 0           $e_string .= $1;
4439 0           $slash = 'div';
4440             }
4441             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4442             # $ @ # \ ' " / ? ( ) [ ] < >
4443             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4444 0           $e_string .= $1;
4445 0           $slash = 'div';
4446             }
4447              
4448             # subroutines of package Char::Elatin3
4449 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4450 0           elsif ($string =~ /\G \b Char::Latin3::eval (?= \s* \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4451 0           elsif ($string =~ /\G \b Char::Latin3::eval \b /oxgc) { $e_string .= 'eval Char::Latin3::escape'; $slash = 'm//'; }
  0            
4452 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4453 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Elatin3::chop'; $slash = 'm//'; }
  0            
4454 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4455 0           elsif ($string =~ /\G \b Char::Latin3::index \b /oxgc) { $e_string .= 'Char::Latin3::index'; $slash = 'm//'; }
  0            
4456 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Elatin3::index'; $slash = 'm//'; }
  0            
4457 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4458 0           elsif ($string =~ /\G \b Char::Latin3::rindex \b /oxgc) { $e_string .= 'Char::Latin3::rindex'; $slash = 'm//'; }
  0            
4459 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Elatin3::rindex'; $slash = 'm//'; }
  0            
4460 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin3::lc'; $slash = 'm//'; }
  0            
4461 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin3::lcfirst'; $slash = 'm//'; }
  0            
4462 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin3::uc'; $slash = 'm//'; }
  0            
4463 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin3::ucfirst'; $slash = 'm//'; }
  0            
4464 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin3::fc'; $slash = 'm//'; }
  0            
4465              
4466             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4467 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4468 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4469 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4470 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4471 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4472 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4473 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            
4474              
4475 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4476 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4477 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4478 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4479 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4480 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4481 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            
4482              
4483             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
4484 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4485 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4486 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4487 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4488              
4489 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4490 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4491 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin3::chr'; $slash = 'm//'; }
  0            
4492 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4493 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4494 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin3::glob'; $slash = 'm//'; }
  0            
4495 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Elatin3::lc_'; $slash = 'm//'; }
  0            
4496 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Elatin3::lcfirst_'; $slash = 'm//'; }
  0            
4497 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Elatin3::uc_'; $slash = 'm//'; }
  0            
4498 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Elatin3::ucfirst_'; $slash = 'm//'; }
  0            
4499 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Elatin3::fc_'; $slash = 'm//'; }
  0            
4500 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4501              
4502 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4503 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4504 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Elatin3::chr_'; $slash = 'm//'; }
  0            
4505 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4506 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4507 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Elatin3::glob_'; $slash = 'm//'; }
  0            
4508 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4509 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4510             # split
4511             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
4512 0           $slash = 'm//';
4513              
4514 0           my $e = '';
4515 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
4516 0           $e .= $1;
4517             }
4518              
4519             # end of split
4520 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin3::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          
4521              
4522             # split scalar value
4523 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4524              
4525             # split literal space
4526 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4527 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4528 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4529 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4530 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4531 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4532 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4533 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4534 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4535 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4536 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4537 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4538 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4539 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Elatin3::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4540              
4541             # split qq//
4542             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4543 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            
4544             else {
4545 0           while ($string !~ /\G \z/oxgc) {
4546 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4547 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4548 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4549 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4550 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4551 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4552 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            
4553             }
4554 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4555             }
4556             }
4557              
4558             # split qr//
4559             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4560 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            
4561             else {
4562 0           while ($string !~ /\G \z/oxgc) {
4563 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4564 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4565 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4566 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4567 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4568 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            
4569 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4570 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            
4571             }
4572 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4573             }
4574             }
4575              
4576             # split q//
4577             elsif ($string =~ /\G \b (q) \b /oxgc) {
4578 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            
4579             else {
4580 0           while ($string !~ /\G \z/oxgc) {
4581 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4582 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4583 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4584 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4585 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4586 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4587 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            
4588             }
4589 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4590             }
4591             }
4592              
4593             # split m//
4594             elsif ($string =~ /\G \b (m) \b /oxgc) {
4595 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            
4596             else {
4597 0           while ($string !~ /\G \z/oxgc) {
4598 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4599 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            
4600 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            
4601 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            
4602 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            
4603 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            
4604 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4605 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            
4606             }
4607 0           die __FILE__, ": Search pattern not terminated";
4608             }
4609             }
4610              
4611             # split ''
4612             elsif ($string =~ /\G (\') /oxgc) {
4613 0           my $q_string = '';
4614 0           while ($string !~ /\G \z/oxgc) {
4615 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4616 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4617 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4618 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4619             }
4620 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4621             }
4622              
4623             # split ""
4624             elsif ($string =~ /\G (\") /oxgc) {
4625 0           my $qq_string = '';
4626 0           while ($string !~ /\G \z/oxgc) {
4627 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4628 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4629 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4630 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4631             }
4632 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4633             }
4634              
4635             # split //
4636             elsif ($string =~ /\G (\/) /oxgc) {
4637 0           my $regexp = '';
4638 0           while ($string !~ /\G \z/oxgc) {
4639 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4640 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4641 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4642 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4643             }
4644 0           die __FILE__, ": Search pattern not terminated";
4645             }
4646             }
4647              
4648             # qq//
4649             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4650 0           my $ope = $1;
4651 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4652 0           $e_string .= e_qq($ope,$1,$3,$2);
4653             }
4654             else {
4655 0           my $e = '';
4656 0           while ($string !~ /\G \z/oxgc) {
4657 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4658 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4659 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4660 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4661 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4662 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4663             }
4664 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4665             }
4666             }
4667              
4668             # qx//
4669             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4670 0           my $ope = $1;
4671 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4672 0           $e_string .= e_qq($ope,$1,$3,$2);
4673             }
4674             else {
4675 0           my $e = '';
4676 0           while ($string !~ /\G \z/oxgc) {
4677 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4678 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4679 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4680 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4681 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4682 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4683 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4684             }
4685 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4686             }
4687             }
4688              
4689             # q//
4690             elsif ($string =~ /\G \b (q) \b /oxgc) {
4691 0           my $ope = $1;
4692 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4693 0           $e_string .= e_q($ope,$1,$3,$2);
4694             }
4695             else {
4696 0           my $e = '';
4697 0           while ($string !~ /\G \z/oxgc) {
4698 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4699 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4700 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4701 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4702 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4703 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            
4704             }
4705 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4706             }
4707             }
4708              
4709             # ''
4710 0           elsif ($string =~ /\G (?
4711              
4712             # ""
4713 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4714              
4715             # ``
4716 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4717              
4718             # <<= <=> <= < operator
4719             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
4720 0           { $e_string .= $1; }
4721              
4722             #
4723 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4724              
4725             # --- glob
4726             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4727 0           $e_string .= 'Char::Elatin3::glob("' . $1 . '")';
4728             }
4729              
4730             # << (bit shift) --- not here document
4731 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4732              
4733             # <<'HEREDOC'
4734             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4735 0           $slash = 'm//';
4736 0           my $here_quote = $1;
4737 0           my $delimiter = $2;
4738              
4739             # get here document
4740 0 0         if ($here_script eq '') {
4741 0           $here_script = CORE::substr $_, pos $_;
4742 0           $here_script =~ s/.*?\n//oxm;
4743             }
4744 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4745 0           push @heredoc, $1 . qq{\n$delimiter\n};
4746 0           push @heredoc_delimiter, $delimiter;
4747             }
4748             else {
4749 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4750             }
4751 0           $e_string .= $here_quote;
4752             }
4753              
4754             # <<\HEREDOC
4755             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4756 0           $slash = 'm//';
4757 0           my $here_quote = $1;
4758 0           my $delimiter = $2;
4759              
4760             # get here document
4761 0 0         if ($here_script eq '') {
4762 0           $here_script = CORE::substr $_, pos $_;
4763 0           $here_script =~ s/.*?\n//oxm;
4764             }
4765 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4766 0           push @heredoc, $1 . qq{\n$delimiter\n};
4767 0           push @heredoc_delimiter, $delimiter;
4768             }
4769             else {
4770 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4771             }
4772 0           $e_string .= $here_quote;
4773             }
4774              
4775             # <<"HEREDOC"
4776             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4777 0           $slash = 'm//';
4778 0           my $here_quote = $1;
4779 0           my $delimiter = $2;
4780              
4781             # get here document
4782 0 0         if ($here_script eq '') {
4783 0           $here_script = CORE::substr $_, pos $_;
4784 0           $here_script =~ s/.*?\n//oxm;
4785             }
4786 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4787 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4788 0           push @heredoc_delimiter, $delimiter;
4789             }
4790             else {
4791 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4792             }
4793 0           $e_string .= $here_quote;
4794             }
4795              
4796             # <
4797             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4798 0           $slash = 'm//';
4799 0           my $here_quote = $1;
4800 0           my $delimiter = $2;
4801              
4802             # get here document
4803 0 0         if ($here_script eq '') {
4804 0           $here_script = CORE::substr $_, pos $_;
4805 0           $here_script =~ s/.*?\n//oxm;
4806             }
4807 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4808 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4809 0           push @heredoc_delimiter, $delimiter;
4810             }
4811             else {
4812 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4813             }
4814 0           $e_string .= $here_quote;
4815             }
4816              
4817             # <<`HEREDOC`
4818             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4819 0           $slash = 'm//';
4820 0           my $here_quote = $1;
4821 0           my $delimiter = $2;
4822              
4823             # get here document
4824 0 0         if ($here_script eq '') {
4825 0           $here_script = CORE::substr $_, pos $_;
4826 0           $here_script =~ s/.*?\n//oxm;
4827             }
4828 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4829 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4830 0           push @heredoc_delimiter, $delimiter;
4831             }
4832             else {
4833 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4834             }
4835 0           $e_string .= $here_quote;
4836             }
4837              
4838             # any operator before div
4839             elsif ($string =~ /\G (
4840             -- | \+\+ |
4841             [\)\}\]]
4842              
4843 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4844              
4845             # yada-yada or triple-dot operator
4846             elsif ($string =~ /\G (
4847             \.\.\.
4848              
4849 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4850              
4851             # any operator before m//
4852             elsif ($string =~ /\G (
4853              
4854             !~~ | !~ | != | ! |
4855             %= | % |
4856             &&= | && | &= | & |
4857             -= | -> | - |
4858             :\s*= |
4859             : |
4860             <<= | <=> | <= | < |
4861             == | => | =~ | = |
4862             >>= | >> | >= | > |
4863             \*\*= | \*\* | \*= | \* |
4864             \+= | \+ |
4865             \.\. | \.= | \. |
4866             \/\/= | \/\/ |
4867             \/= | \/ |
4868             \? |
4869             \\ |
4870             \^= | \^ |
4871             \b x= |
4872             \|\|= | \|\| | \|= | \| |
4873             ~~ | ~ |
4874             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4875             \b(?: print )\b |
4876              
4877             [,;\(\{\[]
4878              
4879 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4880              
4881             # other any character
4882 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4883              
4884             # system error
4885             else {
4886 0           die __FILE__, ": Oops, this shouldn't happen!";
4887             }
4888             }
4889              
4890 0           return $e_string;
4891             }
4892              
4893             #
4894             # character class
4895             #
4896             sub character_class {
4897 0     0 0   my($char,$modifier) = @_;
4898              
4899 0 0         if ($char eq '.') {
4900 0 0         if ($modifier =~ /s/) {
4901 0           return '${Char::Elatin3::dot_s}';
4902             }
4903             else {
4904 0           return '${Char::Elatin3::dot}';
4905             }
4906             }
4907             else {
4908 0           return Char::Elatin3::classic_character_class($char);
4909             }
4910             }
4911              
4912             #
4913             # escape capture ($1, $2, $3, ...)
4914             #
4915             sub e_capture {
4916              
4917 0     0 0   return join '', '${', $_[0], '}';
4918             }
4919              
4920             #
4921             # escape transliteration (tr/// or y///)
4922             #
4923             sub e_tr {
4924 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4925 0           my $e_tr = '';
4926 0   0       $modifier ||= '';
4927              
4928 0           $slash = 'div';
4929              
4930             # quote character class 1
4931 0           $charclass = q_tr($charclass);
4932              
4933             # quote character class 2
4934 0           $charclass2 = q_tr($charclass2);
4935              
4936             # /b /B modifier
4937 0 0         if ($modifier =~ tr/bB//d) {
4938 0 0         if ($variable eq '') {
4939 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4940             }
4941             else {
4942 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4943             }
4944             }
4945             else {
4946 0 0         if ($variable eq '') {
4947 0           $e_tr = qq{Char::Elatin3::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4948             }
4949             else {
4950 0           $e_tr = qq{Char::Elatin3::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4951             }
4952             }
4953              
4954             # clear tr/// variable
4955 0           $tr_variable = '';
4956 0           $bind_operator = '';
4957              
4958 0           return $e_tr;
4959             }
4960              
4961             #
4962             # quote for escape transliteration (tr/// or y///)
4963             #
4964             sub q_tr {
4965 0     0 0   my($charclass) = @_;
4966              
4967             # quote character class
4968 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4969 0           return e_q('', "'", "'", $charclass); # --> q' '
4970             }
4971             elsif ($charclass !~ /\//oxms) {
4972 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4973             }
4974             elsif ($charclass !~ /\#/oxms) {
4975 0           return e_q('q', '#', '#', $charclass); # --> q# #
4976             }
4977             elsif ($charclass !~ /[\<\>]/oxms) {
4978 0           return e_q('q', '<', '>', $charclass); # --> q< >
4979             }
4980             elsif ($charclass !~ /[\(\)]/oxms) {
4981 0           return e_q('q', '(', ')', $charclass); # --> q( )
4982             }
4983             elsif ($charclass !~ /[\{\}]/oxms) {
4984 0           return e_q('q', '{', '}', $charclass); # --> q{ }
4985             }
4986             else {
4987 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4988 0 0         if ($charclass !~ /\Q$char\E/xms) {
4989 0           return e_q('q', $char, $char, $charclass);
4990             }
4991             }
4992             }
4993              
4994 0           return e_q('q', '{', '}', $charclass);
4995             }
4996              
4997             #
4998             # escape q string (q//, '')
4999             #
5000             sub e_q {
5001 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5002              
5003 0           $slash = 'div';
5004              
5005 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5006             }
5007              
5008             #
5009             # escape qq string (qq//, "", qx//, ``)
5010             #
5011             sub e_qq {
5012 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5013              
5014 0           $slash = 'div';
5015              
5016 0           my $left_e = 0;
5017 0           my $right_e = 0;
5018 0           my @char = $string =~ /\G(
5019             \\o\{ [0-7]+ \} |
5020             \\x\{ [0-9A-Fa-f]+ \} |
5021             \\N\{ [^0-9\}][^\}]* \} |
5022             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5023             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5024             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5025             \$ \s* \d+ |
5026             \$ \s* \{ \s* \d+ \s* \} |
5027             \$ \$ (?![\w\{]) |
5028             \$ \s* \$ \s* $qq_variable |
5029             \\?(?:$q_char)
5030             )/oxmsg;
5031              
5032 0           for (my $i=0; $i <= $#char; $i++) {
5033              
5034             # "\L\u" --> "\u\L"
5035 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5036 0           @char[$i,$i+1] = @char[$i+1,$i];
5037             }
5038              
5039             # "\U\l" --> "\l\U"
5040             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5041 0           @char[$i,$i+1] = @char[$i+1,$i];
5042             }
5043              
5044             # octal escape sequence
5045             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5046 0           $char[$i] = Char::Elatin3::octchr($1);
5047             }
5048              
5049             # hexadecimal escape sequence
5050             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5051 0           $char[$i] = Char::Elatin3::hexchr($1);
5052             }
5053              
5054             # \N{CHARNAME} --> N{CHARNAME}
5055             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5056 0           $char[$i] = $1;
5057             }
5058              
5059 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          
5060             }
5061              
5062             # \F
5063             #
5064             # P.69 Table 2-6. Translation escapes
5065             # in Chapter 2: Bits and Pieces
5066             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5067             # (and so on)
5068              
5069             # \u \l \U \L \F \Q \E
5070 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5071 0 0         if ($right_e < $left_e) {
5072 0           $char[$i] = '\\' . $char[$i];
5073             }
5074             }
5075             elsif ($char[$i] eq '\u') {
5076              
5077             # "STRING @{[ LIST EXPR ]} MORE STRING"
5078              
5079             # P.257 Other Tricks You Can Do with Hard References
5080             # in Chapter 8: References
5081             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5082              
5083             # P.353 Other Tricks You Can Do with Hard References
5084             # in Chapter 8: References
5085             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5086              
5087             # (and so on)
5088              
5089 0           $char[$i] = '@{[Char::Elatin3::ucfirst qq<';
5090 0           $left_e++;
5091             }
5092             elsif ($char[$i] eq '\l') {
5093 0           $char[$i] = '@{[Char::Elatin3::lcfirst qq<';
5094 0           $left_e++;
5095             }
5096             elsif ($char[$i] eq '\U') {
5097 0           $char[$i] = '@{[Char::Elatin3::uc qq<';
5098 0           $left_e++;
5099             }
5100             elsif ($char[$i] eq '\L') {
5101 0           $char[$i] = '@{[Char::Elatin3::lc qq<';
5102 0           $left_e++;
5103             }
5104             elsif ($char[$i] eq '\F') {
5105 0           $char[$i] = '@{[Char::Elatin3::fc qq<';
5106 0           $left_e++;
5107             }
5108             elsif ($char[$i] eq '\Q') {
5109 0           $char[$i] = '@{[CORE::quotemeta qq<';
5110 0           $left_e++;
5111             }
5112             elsif ($char[$i] eq '\E') {
5113 0 0         if ($right_e < $left_e) {
5114 0           $char[$i] = '>]}';
5115 0           $right_e++;
5116             }
5117             else {
5118 0           $char[$i] = '';
5119             }
5120             }
5121             elsif ($char[$i] eq '\Q') {
5122 0           while (1) {
5123 0 0         if (++$i > $#char) {
5124 0           last;
5125             }
5126 0 0         if ($char[$i] eq '\E') {
5127 0           last;
5128             }
5129             }
5130             }
5131             elsif ($char[$i] eq '\E') {
5132             }
5133              
5134             # $0 --> $0
5135             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5136             }
5137             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5138             }
5139              
5140             # $$ --> $$
5141             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5142             }
5143              
5144             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5145             # $1, $2, $3 --> $1, $2, $3 otherwise
5146             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5147 0           $char[$i] = e_capture($1);
5148             }
5149             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5150 0           $char[$i] = e_capture($1);
5151             }
5152              
5153             # $$foo[ ... ] --> $ $foo->[ ... ]
5154             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5155 0           $char[$i] = e_capture($1.'->'.$2);
5156             }
5157              
5158             # $$foo{ ... } --> $ $foo->{ ... }
5159             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5160 0           $char[$i] = e_capture($1.'->'.$2);
5161             }
5162              
5163             # $$foo
5164             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5165 0           $char[$i] = e_capture($1);
5166             }
5167              
5168             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin3::PREMATCH()
5169             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5170 0           $char[$i] = '@{[Char::Elatin3::PREMATCH()]}';
5171             }
5172              
5173             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin3::MATCH()
5174             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5175 0           $char[$i] = '@{[Char::Elatin3::MATCH()]}';
5176             }
5177              
5178             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin3::POSTMATCH()
5179             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5180 0           $char[$i] = '@{[Char::Elatin3::POSTMATCH()]}';
5181             }
5182              
5183             # ${ foo } --> ${ foo }
5184             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5185             }
5186              
5187             # ${ ... }
5188             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5189 0           $char[$i] = e_capture($1);
5190             }
5191             }
5192              
5193             # return string
5194 0 0         if ($left_e > $right_e) {
5195 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5196             }
5197 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5198             }
5199              
5200             #
5201             # escape qw string (qw//)
5202             #
5203             sub e_qw {
5204 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5205              
5206 0           $slash = 'div';
5207              
5208             # choice again delimiter
5209 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5210 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5211 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5212             }
5213             elsif (not $octet{')'}) {
5214 0           return join '', $ope, '(', $string, ')';
5215             }
5216             elsif (not $octet{'}'}) {
5217 0           return join '', $ope, '{', $string, '}';
5218             }
5219             elsif (not $octet{']'}) {
5220 0           return join '', $ope, '[', $string, ']';
5221             }
5222             elsif (not $octet{'>'}) {
5223 0           return join '', $ope, '<', $string, '>';
5224             }
5225             else {
5226 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5227 0 0         if (not $octet{$char}) {
5228 0           return join '', $ope, $char, $string, $char;
5229             }
5230             }
5231             }
5232              
5233             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5234 0           my @string = CORE::split(/\s+/, $string);
5235 0           for my $string (@string) {
5236 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5237 0           for my $octet (@octet) {
5238 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5239 0           $octet = '\\' . $1;
5240             }
5241             }
5242 0           $string = join '', @octet;
5243             }
5244 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5245             }
5246              
5247             #
5248             # escape here document (<<"HEREDOC", <
5249             #
5250             sub e_heredoc {
5251 0     0 0   my($string) = @_;
5252              
5253 0           $slash = 'm//';
5254              
5255 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5256              
5257 0           my $left_e = 0;
5258 0           my $right_e = 0;
5259 0           my @char = $string =~ /\G(
5260             \\o\{ [0-7]+ \} |
5261             \\x\{ [0-9A-Fa-f]+ \} |
5262             \\N\{ [^0-9\}][^\}]* \} |
5263             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5264             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5265             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5266             \$ \s* \d+ |
5267             \$ \s* \{ \s* \d+ \s* \} |
5268             \$ \$ (?![\w\{]) |
5269             \$ \s* \$ \s* $qq_variable |
5270             \\?(?:$q_char)
5271             )/oxmsg;
5272              
5273 0           for (my $i=0; $i <= $#char; $i++) {
5274              
5275             # "\L\u" --> "\u\L"
5276 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5277 0           @char[$i,$i+1] = @char[$i+1,$i];
5278             }
5279              
5280             # "\U\l" --> "\l\U"
5281             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5282 0           @char[$i,$i+1] = @char[$i+1,$i];
5283             }
5284              
5285             # octal escape sequence
5286             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5287 0           $char[$i] = Char::Elatin3::octchr($1);
5288             }
5289              
5290             # hexadecimal escape sequence
5291             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5292 0           $char[$i] = Char::Elatin3::hexchr($1);
5293             }
5294              
5295             # \N{CHARNAME} --> N{CHARNAME}
5296             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5297 0           $char[$i] = $1;
5298             }
5299              
5300 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          
5301             }
5302              
5303             # \u \l \U \L \F \Q \E
5304 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5305 0 0         if ($right_e < $left_e) {
5306 0           $char[$i] = '\\' . $char[$i];
5307             }
5308             }
5309             elsif ($char[$i] eq '\u') {
5310 0           $char[$i] = '@{[Char::Elatin3::ucfirst qq<';
5311 0           $left_e++;
5312             }
5313             elsif ($char[$i] eq '\l') {
5314 0           $char[$i] = '@{[Char::Elatin3::lcfirst qq<';
5315 0           $left_e++;
5316             }
5317             elsif ($char[$i] eq '\U') {
5318 0           $char[$i] = '@{[Char::Elatin3::uc qq<';
5319 0           $left_e++;
5320             }
5321             elsif ($char[$i] eq '\L') {
5322 0           $char[$i] = '@{[Char::Elatin3::lc qq<';
5323 0           $left_e++;
5324             }
5325             elsif ($char[$i] eq '\F') {
5326 0           $char[$i] = '@{[Char::Elatin3::fc qq<';
5327 0           $left_e++;
5328             }
5329             elsif ($char[$i] eq '\Q') {
5330 0           $char[$i] = '@{[CORE::quotemeta qq<';
5331 0           $left_e++;
5332             }
5333             elsif ($char[$i] eq '\E') {
5334 0 0         if ($right_e < $left_e) {
5335 0           $char[$i] = '>]}';
5336 0           $right_e++;
5337             }
5338             else {
5339 0           $char[$i] = '';
5340             }
5341             }
5342             elsif ($char[$i] eq '\Q') {
5343 0           while (1) {
5344 0 0         if (++$i > $#char) {
5345 0           last;
5346             }
5347 0 0         if ($char[$i] eq '\E') {
5348 0           last;
5349             }
5350             }
5351             }
5352             elsif ($char[$i] eq '\E') {
5353             }
5354              
5355             # $0 --> $0
5356             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5357             }
5358             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5359             }
5360              
5361             # $$ --> $$
5362             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5363             }
5364              
5365             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5366             # $1, $2, $3 --> $1, $2, $3 otherwise
5367             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5368 0           $char[$i] = e_capture($1);
5369             }
5370             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5371 0           $char[$i] = e_capture($1);
5372             }
5373              
5374             # $$foo[ ... ] --> $ $foo->[ ... ]
5375             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5376 0           $char[$i] = e_capture($1.'->'.$2);
5377             }
5378              
5379             # $$foo{ ... } --> $ $foo->{ ... }
5380             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5381 0           $char[$i] = e_capture($1.'->'.$2);
5382             }
5383              
5384             # $$foo
5385             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5386 0           $char[$i] = e_capture($1);
5387             }
5388              
5389             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin3::PREMATCH()
5390             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5391 0           $char[$i] = '@{[Char::Elatin3::PREMATCH()]}';
5392             }
5393              
5394             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin3::MATCH()
5395             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5396 0           $char[$i] = '@{[Char::Elatin3::MATCH()]}';
5397             }
5398              
5399             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin3::POSTMATCH()
5400             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5401 0           $char[$i] = '@{[Char::Elatin3::POSTMATCH()]}';
5402             }
5403              
5404             # ${ foo } --> ${ foo }
5405             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5406             }
5407              
5408             # ${ ... }
5409             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5410 0           $char[$i] = e_capture($1);
5411             }
5412             }
5413              
5414             # return string
5415 0 0         if ($left_e > $right_e) {
5416 0           return join '', @char, '>]}' x ($left_e - $right_e);
5417             }
5418 0           return join '', @char;
5419             }
5420              
5421             #
5422             # escape regexp (m//, qr//)
5423             #
5424             sub e_qr {
5425 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5426 0   0       $modifier ||= '';
5427              
5428 0           $modifier =~ tr/p//d;
5429 0 0         if ($modifier =~ /([adlu])/oxms) {
5430 0           my $line = 0;
5431 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5432 0 0         if ($filename ne __FILE__) {
5433 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5434 0           last;
5435             }
5436             }
5437 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5438             }
5439              
5440 0           $slash = 'div';
5441              
5442             # literal null string pattern
5443 0 0         if ($string eq '') {
    0          
5444 0           $modifier =~ tr/bB//d;
5445 0           $modifier =~ tr/i//d;
5446 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5447             }
5448              
5449             # /b /B modifier
5450             elsif ($modifier =~ tr/bB//d) {
5451              
5452             # choice again delimiter
5453 0 0         if ($delimiter =~ / [\@:] /oxms) {
5454 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5455 0           my %octet = map {$_ => 1} @char;
  0            
5456 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5457 0           $delimiter = '(';
5458 0           $end_delimiter = ')';
5459             }
5460             elsif (not $octet{'}'}) {
5461 0           $delimiter = '{';
5462 0           $end_delimiter = '}';
5463             }
5464             elsif (not $octet{']'}) {
5465 0           $delimiter = '[';
5466 0           $end_delimiter = ']';
5467             }
5468             elsif (not $octet{'>'}) {
5469 0           $delimiter = '<';
5470 0           $end_delimiter = '>';
5471             }
5472             else {
5473 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5474 0 0         if (not $octet{$char}) {
5475 0           $delimiter = $char;
5476 0           $end_delimiter = $char;
5477 0           last;
5478             }
5479             }
5480             }
5481             }
5482              
5483 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5484 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5485             }
5486             else {
5487 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5488             }
5489             }
5490              
5491 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5492 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5493              
5494             # split regexp
5495 0           my @char = $string =~ /\G(
5496             \\o\{ [0-7]+ \} |
5497             \\ [0-7]{2,3} |
5498             \\x\{ [0-9A-Fa-f]+ \} |
5499             \\x [0-9A-Fa-f]{1,2} |
5500             \\c [\x40-\x5F] |
5501             \\N\{ [^0-9\}][^\}]* \} |
5502             \\p\{ [^0-9\}][^\}]* \} |
5503             \\P\{ [^0-9\}][^\}]* \} |
5504             \\ (?:$q_char) |
5505             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5506             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5507             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5508             [\$\@] $qq_variable |
5509             \$ \s* \d+ |
5510             \$ \s* \{ \s* \d+ \s* \} |
5511             \$ \$ (?![\w\{]) |
5512             \$ \s* \$ \s* $qq_variable |
5513             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5514             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5515             \[\^ |
5516             \(\? |
5517             (?:$q_char)
5518             )/oxmsg;
5519              
5520             # choice again delimiter
5521 0 0         if ($delimiter =~ / [\@:] /oxms) {
5522 0           my %octet = map {$_ => 1} @char;
  0            
5523 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5524 0           $delimiter = '(';
5525 0           $end_delimiter = ')';
5526             }
5527             elsif (not $octet{'}'}) {
5528 0           $delimiter = '{';
5529 0           $end_delimiter = '}';
5530             }
5531             elsif (not $octet{']'}) {
5532 0           $delimiter = '[';
5533 0           $end_delimiter = ']';
5534             }
5535             elsif (not $octet{'>'}) {
5536 0           $delimiter = '<';
5537 0           $end_delimiter = '>';
5538             }
5539             else {
5540 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5541 0 0         if (not $octet{$char}) {
5542 0           $delimiter = $char;
5543 0           $end_delimiter = $char;
5544 0           last;
5545             }
5546             }
5547             }
5548             }
5549              
5550 0           my $left_e = 0;
5551 0           my $right_e = 0;
5552 0           for (my $i=0; $i <= $#char; $i++) {
5553              
5554             # "\L\u" --> "\u\L"
5555 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
5556 0           @char[$i,$i+1] = @char[$i+1,$i];
5557             }
5558              
5559             # "\U\l" --> "\l\U"
5560             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5561 0           @char[$i,$i+1] = @char[$i+1,$i];
5562             }
5563              
5564             # octal escape sequence
5565             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5566 0           $char[$i] = Char::Elatin3::octchr($1);
5567             }
5568              
5569             # hexadecimal escape sequence
5570             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5571 0           $char[$i] = Char::Elatin3::hexchr($1);
5572             }
5573              
5574             # \N{CHARNAME} --> N\{CHARNAME}
5575             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5576 0           $char[$i] = $1 . '\\' . $2;
5577             }
5578              
5579             # \p{PROPERTY} --> p\{PROPERTY}
5580             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5581 0           $char[$i] = $1 . '\\' . $2;
5582             }
5583              
5584             # \P{PROPERTY} --> P\{PROPERTY}
5585             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5586 0           $char[$i] = $1 . '\\' . $2;
5587             }
5588              
5589             # \p, \P, \X --> p, P, X
5590             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5591 0           $char[$i] = $1;
5592             }
5593              
5594 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          
5595             }
5596              
5597             # join separated multiple-octet
5598 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5599 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        
5600 0           $char[$i] .= join '', splice @char, $i+1, 3;
5601             }
5602             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)) {
5603 0           $char[$i] .= join '', splice @char, $i+1, 2;
5604             }
5605             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)) {
5606 0           $char[$i] .= join '', splice @char, $i+1, 1;
5607             }
5608             }
5609              
5610             # open character class [...]
5611             elsif ($char[$i] eq '[') {
5612 0           my $left = $i;
5613              
5614             # [] make die "Unmatched [] in regexp ..."
5615             # (and so on)
5616              
5617 0 0         if ($char[$i+1] eq ']') {
5618 0           $i++;
5619             }
5620              
5621 0           while (1) {
5622 0 0         if (++$i > $#char) {
5623 0           die __FILE__, ": Unmatched [] in regexp";
5624             }
5625 0 0         if ($char[$i] eq ']') {
5626 0           my $right = $i;
5627              
5628             # [...]
5629 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5630 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin3::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5631             }
5632             else {
5633 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
5634             }
5635              
5636 0           $i = $left;
5637 0           last;
5638             }
5639             }
5640             }
5641              
5642             # open character class [^...]
5643             elsif ($char[$i] eq '[^') {
5644 0           my $left = $i;
5645              
5646             # [^] make die "Unmatched [] in regexp ..."
5647             # (and so on)
5648              
5649 0 0         if ($char[$i+1] eq ']') {
5650 0           $i++;
5651             }
5652              
5653 0           while (1) {
5654 0 0         if (++$i > $#char) {
5655 0           die __FILE__, ": Unmatched [] in regexp";
5656             }
5657 0 0         if ($char[$i] eq ']') {
5658 0           my $right = $i;
5659              
5660             # [^...]
5661 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5662 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin3::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5663             }
5664             else {
5665 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5666             }
5667              
5668 0           $i = $left;
5669 0           last;
5670             }
5671             }
5672             }
5673              
5674             # rewrite character class or escape character
5675             elsif (my $char = character_class($char[$i],$modifier)) {
5676 0           $char[$i] = $char;
5677             }
5678              
5679             # /i modifier
5680             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin3::uc($char[$i]) ne Char::Elatin3::fc($char[$i]))) {
5681 0 0         if (CORE::length(Char::Elatin3::fc($char[$i])) == 1) {
5682 0           $char[$i] = '[' . Char::Elatin3::uc($char[$i]) . Char::Elatin3::fc($char[$i]) . ']';
5683             }
5684             else {
5685 0           $char[$i] = '(?:' . Char::Elatin3::uc($char[$i]) . '|' . Char::Elatin3::fc($char[$i]) . ')';
5686             }
5687             }
5688              
5689             # \u \l \U \L \F \Q \E
5690             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5691 0 0         if ($right_e < $left_e) {
5692 0           $char[$i] = '\\' . $char[$i];
5693             }
5694             }
5695             elsif ($char[$i] eq '\u') {
5696 0           $char[$i] = '@{[Char::Elatin3::ucfirst qq<';
5697 0           $left_e++;
5698             }
5699             elsif ($char[$i] eq '\l') {
5700 0           $char[$i] = '@{[Char::Elatin3::lcfirst qq<';
5701 0           $left_e++;
5702             }
5703             elsif ($char[$i] eq '\U') {
5704 0           $char[$i] = '@{[Char::Elatin3::uc qq<';
5705 0           $left_e++;
5706             }
5707             elsif ($char[$i] eq '\L') {
5708 0           $char[$i] = '@{[Char::Elatin3::lc qq<';
5709 0           $left_e++;
5710             }
5711             elsif ($char[$i] eq '\F') {
5712 0           $char[$i] = '@{[Char::Elatin3::fc qq<';
5713 0           $left_e++;
5714             }
5715             elsif ($char[$i] eq '\Q') {
5716 0           $char[$i] = '@{[CORE::quotemeta qq<';
5717 0           $left_e++;
5718             }
5719             elsif ($char[$i] eq '\E') {
5720 0 0         if ($right_e < $left_e) {
5721 0           $char[$i] = '>]}';
5722 0           $right_e++;
5723             }
5724             else {
5725 0           $char[$i] = '';
5726             }
5727             }
5728             elsif ($char[$i] eq '\Q') {
5729 0           while (1) {
5730 0 0         if (++$i > $#char) {
5731 0           last;
5732             }
5733 0 0         if ($char[$i] eq '\E') {
5734 0           last;
5735             }
5736             }
5737             }
5738             elsif ($char[$i] eq '\E') {
5739             }
5740              
5741             # $0 --> $0
5742             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5743 0 0         if ($ignorecase) {
5744 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5745             }
5746             }
5747             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5748 0 0         if ($ignorecase) {
5749 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5750             }
5751             }
5752              
5753             # $$ --> $$
5754             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5755             }
5756              
5757             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5758             # $1, $2, $3 --> $1, $2, $3 otherwise
5759             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5760 0           $char[$i] = e_capture($1);
5761 0 0         if ($ignorecase) {
5762 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5763             }
5764             }
5765             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5766 0           $char[$i] = e_capture($1);
5767 0 0         if ($ignorecase) {
5768 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5769             }
5770             }
5771              
5772             # $$foo[ ... ] --> $ $foo->[ ... ]
5773             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5774 0           $char[$i] = e_capture($1.'->'.$2);
5775 0 0         if ($ignorecase) {
5776 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5777             }
5778             }
5779              
5780             # $$foo{ ... } --> $ $foo->{ ... }
5781             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5782 0           $char[$i] = e_capture($1.'->'.$2);
5783 0 0         if ($ignorecase) {
5784 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5785             }
5786             }
5787              
5788             # $$foo
5789             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5790 0           $char[$i] = e_capture($1);
5791 0 0         if ($ignorecase) {
5792 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5793             }
5794             }
5795              
5796             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin3::PREMATCH()
5797             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5798 0 0         if ($ignorecase) {
5799 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::PREMATCH())]}';
5800             }
5801             else {
5802 0           $char[$i] = '@{[Char::Elatin3::PREMATCH()]}';
5803             }
5804             }
5805              
5806             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin3::MATCH()
5807             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5808 0 0         if ($ignorecase) {
5809 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::MATCH())]}';
5810             }
5811             else {
5812 0           $char[$i] = '@{[Char::Elatin3::MATCH()]}';
5813             }
5814             }
5815              
5816             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin3::POSTMATCH()
5817             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5818 0 0         if ($ignorecase) {
5819 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::POSTMATCH())]}';
5820             }
5821             else {
5822 0           $char[$i] = '@{[Char::Elatin3::POSTMATCH()]}';
5823             }
5824             }
5825              
5826             # ${ foo }
5827             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5828 0 0         if ($ignorecase) {
5829 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5830             }
5831             }
5832              
5833             # ${ ... }
5834             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5835 0           $char[$i] = e_capture($1);
5836 0 0         if ($ignorecase) {
5837 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5838             }
5839             }
5840              
5841             # $scalar or @array
5842             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5843 0           $char[$i] = e_string($char[$i]);
5844 0 0         if ($ignorecase) {
5845 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
5846             }
5847             }
5848              
5849             # quote character before ? + * {
5850             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5851 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5852             }
5853             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5854 0           my $char = $char[$i-1];
5855 0 0         if ($char[$i] eq '{') {
5856 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
5857             }
5858             else {
5859 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
5860             }
5861             }
5862             else {
5863 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5864             }
5865             }
5866             }
5867              
5868             # make regexp string
5869 0           $modifier =~ tr/i//d;
5870 0 0         if ($left_e > $right_e) {
5871 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5872 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5873             }
5874             else {
5875 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5876             }
5877             }
5878 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5879 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5880             }
5881             else {
5882 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5883             }
5884             }
5885              
5886             #
5887             # double quote stuff
5888             #
5889             sub qq_stuff {
5890 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5891              
5892             # scalar variable or array variable
5893 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5894 0           return $stuff;
5895             }
5896              
5897             # quote by delimiter
5898 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5899 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5900 0 0         next if $char eq $delimiter;
5901 0 0         next if $char eq $end_delimiter;
5902 0 0         if (not $octet{$char}) {
5903 0           return join '', 'qq', $char, $stuff, $char;
5904             }
5905             }
5906 0           return join '', 'qq', '<', $stuff, '>';
5907             }
5908              
5909             #
5910             # escape regexp (m'', qr'', and m''b, qr''b)
5911             #
5912             sub e_qr_q {
5913 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5914 0   0       $modifier ||= '';
5915              
5916 0           $modifier =~ tr/p//d;
5917 0 0         if ($modifier =~ /([adlu])/oxms) {
5918 0           my $line = 0;
5919 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5920 0 0         if ($filename ne __FILE__) {
5921 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5922 0           last;
5923             }
5924             }
5925 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5926             }
5927              
5928 0           $slash = 'div';
5929              
5930             # literal null string pattern
5931 0 0         if ($string eq '') {
    0          
5932 0           $modifier =~ tr/bB//d;
5933 0           $modifier =~ tr/i//d;
5934 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5935             }
5936              
5937             # with /b /B modifier
5938             elsif ($modifier =~ tr/bB//d) {
5939 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5940             }
5941              
5942             # without /b /B modifier
5943             else {
5944 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5945             }
5946             }
5947              
5948             #
5949             # escape regexp (m'', qr'')
5950             #
5951             sub e_qr_qt {
5952 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5953              
5954 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5955              
5956             # split regexp
5957 0           my @char = $string =~ /\G(
5958             \[\:\^ [a-z]+ \:\] |
5959             \[\: [a-z]+ \:\] |
5960             \[\^ |
5961             [\$\@\/\\] |
5962             \\? (?:$q_char)
5963             )/oxmsg;
5964              
5965             # unescape character
5966 0           for (my $i=0; $i <= $#char; $i++) {
5967 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5968             }
5969              
5970             # open character class [...]
5971 0           elsif ($char[$i] eq '[') {
5972 0           my $left = $i;
5973 0 0         if ($char[$i+1] eq ']') {
5974 0           $i++;
5975             }
5976 0           while (1) {
5977 0 0         if (++$i > $#char) {
5978 0           die __FILE__, ": Unmatched [] in regexp";
5979             }
5980 0 0         if ($char[$i] eq ']') {
5981 0           my $right = $i;
5982              
5983             # [...]
5984 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
5985              
5986 0           $i = $left;
5987 0           last;
5988             }
5989             }
5990             }
5991              
5992             # open character class [^...]
5993             elsif ($char[$i] eq '[^') {
5994 0           my $left = $i;
5995 0 0         if ($char[$i+1] eq ']') {
5996 0           $i++;
5997             }
5998 0           while (1) {
5999 0 0         if (++$i > $#char) {
6000 0           die __FILE__, ": Unmatched [] in regexp";
6001             }
6002 0 0         if ($char[$i] eq ']') {
6003 0           my $right = $i;
6004              
6005             # [^...]
6006 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6007              
6008 0           $i = $left;
6009 0           last;
6010             }
6011             }
6012             }
6013              
6014             # escape $ @ / and \
6015             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6016 0           $char[$i] = '\\' . $char[$i];
6017             }
6018              
6019             # rewrite character class or escape character
6020             elsif (my $char = character_class($char[$i],$modifier)) {
6021 0           $char[$i] = $char;
6022             }
6023              
6024             # /i modifier
6025             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin3::uc($char[$i]) ne Char::Elatin3::fc($char[$i]))) {
6026 0 0         if (CORE::length(Char::Elatin3::fc($char[$i])) == 1) {
6027 0           $char[$i] = '[' . Char::Elatin3::uc($char[$i]) . Char::Elatin3::fc($char[$i]) . ']';
6028             }
6029             else {
6030 0           $char[$i] = '(?:' . Char::Elatin3::uc($char[$i]) . '|' . Char::Elatin3::fc($char[$i]) . ')';
6031             }
6032             }
6033              
6034             # quote character before ? + * {
6035             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6036 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6037             }
6038             else {
6039 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6040             }
6041             }
6042             }
6043              
6044 0           $delimiter = '/';
6045 0           $end_delimiter = '/';
6046              
6047 0           $modifier =~ tr/i//d;
6048 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6049             }
6050              
6051             #
6052             # escape regexp (m''b, qr''b)
6053             #
6054             sub e_qr_qb {
6055 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6056              
6057             # split regexp
6058 0           my @char = $string =~ /\G(
6059             \\\\ |
6060             [\$\@\/\\] |
6061             [\x00-\xFF]
6062             )/oxmsg;
6063              
6064             # unescape character
6065 0           for (my $i=0; $i <= $#char; $i++) {
6066 0 0         if (0) {
    0          
6067             }
6068              
6069             # remain \\
6070 0           elsif ($char[$i] eq '\\\\') {
6071             }
6072              
6073             # escape $ @ / and \
6074             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6075 0           $char[$i] = '\\' . $char[$i];
6076             }
6077             }
6078              
6079 0           $delimiter = '/';
6080 0           $end_delimiter = '/';
6081 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6082             }
6083              
6084             #
6085             # escape regexp (s/here//)
6086             #
6087             sub e_s1 {
6088 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6089 0   0       $modifier ||= '';
6090              
6091 0           $modifier =~ tr/p//d;
6092 0 0         if ($modifier =~ /([adlu])/oxms) {
6093 0           my $line = 0;
6094 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6095 0 0         if ($filename ne __FILE__) {
6096 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6097 0           last;
6098             }
6099             }
6100 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6101             }
6102              
6103 0           $slash = 'div';
6104              
6105             # literal null string pattern
6106 0 0         if ($string eq '') {
    0          
6107 0           $modifier =~ tr/bB//d;
6108 0           $modifier =~ tr/i//d;
6109 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6110             }
6111              
6112             # /b /B modifier
6113             elsif ($modifier =~ tr/bB//d) {
6114              
6115             # choice again delimiter
6116 0 0         if ($delimiter =~ / [\@:] /oxms) {
6117 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
6118 0           my %octet = map {$_ => 1} @char;
  0            
6119 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6120 0           $delimiter = '(';
6121 0           $end_delimiter = ')';
6122             }
6123             elsif (not $octet{'}'}) {
6124 0           $delimiter = '{';
6125 0           $end_delimiter = '}';
6126             }
6127             elsif (not $octet{']'}) {
6128 0           $delimiter = '[';
6129 0           $end_delimiter = ']';
6130             }
6131             elsif (not $octet{'>'}) {
6132 0           $delimiter = '<';
6133 0           $end_delimiter = '>';
6134             }
6135             else {
6136 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6137 0 0         if (not $octet{$char}) {
6138 0           $delimiter = $char;
6139 0           $end_delimiter = $char;
6140 0           last;
6141             }
6142             }
6143             }
6144             }
6145              
6146 0           my $prematch = '';
6147 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6148             }
6149              
6150 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6151 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6152              
6153             # split regexp
6154 0           my @char = $string =~ /\G(
6155             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
6156             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
6157             \\g \s* [1-9][0-9]* |
6158             \\o\{ [0-7]+ \} |
6159             \\ [1-9][0-9]* |
6160             \\ [0-7]{2,3} |
6161             \\x\{ [0-9A-Fa-f]+ \} |
6162             \\x [0-9A-Fa-f]{1,2} |
6163             \\c [\x40-\x5F] |
6164             \\N\{ [^0-9\}][^\}]* \} |
6165             \\p\{ [^0-9\}][^\}]* \} |
6166             \\P\{ [^0-9\}][^\}]* \} |
6167             \\ (?:$q_char) |
6168             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6169             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6170             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6171             [\$\@] $qq_variable |
6172             \$ \s* \d+ |
6173             \$ \s* \{ \s* \d+ \s* \} |
6174             \$ \$ (?![\w\{]) |
6175             \$ \s* \$ \s* $qq_variable |
6176             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6177             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6178             \[\^ |
6179             \(\? |
6180             (?:$q_char)
6181             )/oxmsg;
6182              
6183             # choice again delimiter
6184 0 0         if ($delimiter =~ / [\@:] /oxms) {
6185 0           my %octet = map {$_ => 1} @char;
  0            
6186 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6187 0           $delimiter = '(';
6188 0           $end_delimiter = ')';
6189             }
6190             elsif (not $octet{'}'}) {
6191 0           $delimiter = '{';
6192 0           $end_delimiter = '}';
6193             }
6194             elsif (not $octet{']'}) {
6195 0           $delimiter = '[';
6196 0           $end_delimiter = ']';
6197             }
6198             elsif (not $octet{'>'}) {
6199 0           $delimiter = '<';
6200 0           $end_delimiter = '>';
6201             }
6202             else {
6203 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6204 0 0         if (not $octet{$char}) {
6205 0           $delimiter = $char;
6206 0           $end_delimiter = $char;
6207 0           last;
6208             }
6209             }
6210             }
6211             }
6212              
6213             # count '('
6214 0           my $parens = grep { $_ eq '(' } @char;
  0            
6215              
6216 0           my $left_e = 0;
6217 0           my $right_e = 0;
6218 0           for (my $i=0; $i <= $#char; $i++) {
6219              
6220             # "\L\u" --> "\u\L"
6221 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6222 0           @char[$i,$i+1] = @char[$i+1,$i];
6223             }
6224              
6225             # "\U\l" --> "\l\U"
6226             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6227 0           @char[$i,$i+1] = @char[$i+1,$i];
6228             }
6229              
6230             # octal escape sequence
6231             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6232 0           $char[$i] = Char::Elatin3::octchr($1);
6233             }
6234              
6235             # hexadecimal escape sequence
6236             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6237 0           $char[$i] = Char::Elatin3::hexchr($1);
6238             }
6239              
6240             # \N{CHARNAME} --> N\{CHARNAME}
6241             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6242 0           $char[$i] = $1 . '\\' . $2;
6243             }
6244              
6245             # \p{PROPERTY} --> p\{PROPERTY}
6246             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6247 0           $char[$i] = $1 . '\\' . $2;
6248             }
6249              
6250             # \P{PROPERTY} --> P\{PROPERTY}
6251             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6252 0           $char[$i] = $1 . '\\' . $2;
6253             }
6254              
6255             # \p, \P, \X --> p, P, X
6256             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6257 0           $char[$i] = $1;
6258             }
6259              
6260 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          
6261             }
6262              
6263             # join separated multiple-octet
6264 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6265 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        
6266 0           $char[$i] .= join '', splice @char, $i+1, 3;
6267             }
6268             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)) {
6269 0           $char[$i] .= join '', splice @char, $i+1, 2;
6270             }
6271             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)) {
6272 0           $char[$i] .= join '', splice @char, $i+1, 1;
6273             }
6274             }
6275              
6276             # open character class [...]
6277             elsif ($char[$i] eq '[') {
6278 0           my $left = $i;
6279 0 0         if ($char[$i+1] eq ']') {
6280 0           $i++;
6281             }
6282 0           while (1) {
6283 0 0         if (++$i > $#char) {
6284 0           die __FILE__, ": Unmatched [] in regexp";
6285             }
6286 0 0         if ($char[$i] eq ']') {
6287 0           my $right = $i;
6288              
6289             # [...]
6290 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6291 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin3::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6292             }
6293             else {
6294 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
6295             }
6296              
6297 0           $i = $left;
6298 0           last;
6299             }
6300             }
6301             }
6302              
6303             # open character class [^...]
6304             elsif ($char[$i] eq '[^') {
6305 0           my $left = $i;
6306 0 0         if ($char[$i+1] eq ']') {
6307 0           $i++;
6308             }
6309 0           while (1) {
6310 0 0         if (++$i > $#char) {
6311 0           die __FILE__, ": Unmatched [] in regexp";
6312             }
6313 0 0         if ($char[$i] eq ']') {
6314 0           my $right = $i;
6315              
6316             # [^...]
6317 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6318 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin3::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6319             }
6320             else {
6321 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6322             }
6323              
6324 0           $i = $left;
6325 0           last;
6326             }
6327             }
6328             }
6329              
6330             # rewrite character class or escape character
6331             elsif (my $char = character_class($char[$i],$modifier)) {
6332 0           $char[$i] = $char;
6333             }
6334              
6335             # /i modifier
6336             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin3::uc($char[$i]) ne Char::Elatin3::fc($char[$i]))) {
6337 0 0         if (CORE::length(Char::Elatin3::fc($char[$i])) == 1) {
6338 0           $char[$i] = '[' . Char::Elatin3::uc($char[$i]) . Char::Elatin3::fc($char[$i]) . ']';
6339             }
6340             else {
6341 0           $char[$i] = '(?:' . Char::Elatin3::uc($char[$i]) . '|' . Char::Elatin3::fc($char[$i]) . ')';
6342             }
6343             }
6344              
6345             # \u \l \U \L \F \Q \E
6346             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6347 0 0         if ($right_e < $left_e) {
6348 0           $char[$i] = '\\' . $char[$i];
6349             }
6350             }
6351             elsif ($char[$i] eq '\u') {
6352 0           $char[$i] = '@{[Char::Elatin3::ucfirst qq<';
6353 0           $left_e++;
6354             }
6355             elsif ($char[$i] eq '\l') {
6356 0           $char[$i] = '@{[Char::Elatin3::lcfirst qq<';
6357 0           $left_e++;
6358             }
6359             elsif ($char[$i] eq '\U') {
6360 0           $char[$i] = '@{[Char::Elatin3::uc qq<';
6361 0           $left_e++;
6362             }
6363             elsif ($char[$i] eq '\L') {
6364 0           $char[$i] = '@{[Char::Elatin3::lc qq<';
6365 0           $left_e++;
6366             }
6367             elsif ($char[$i] eq '\F') {
6368 0           $char[$i] = '@{[Char::Elatin3::fc qq<';
6369 0           $left_e++;
6370             }
6371             elsif ($char[$i] eq '\Q') {
6372 0           $char[$i] = '@{[CORE::quotemeta qq<';
6373 0           $left_e++;
6374             }
6375             elsif ($char[$i] eq '\E') {
6376 0 0         if ($right_e < $left_e) {
6377 0           $char[$i] = '>]}';
6378 0           $right_e++;
6379             }
6380             else {
6381 0           $char[$i] = '';
6382             }
6383             }
6384             elsif ($char[$i] eq '\Q') {
6385 0           while (1) {
6386 0 0         if (++$i > $#char) {
6387 0           last;
6388             }
6389 0 0         if ($char[$i] eq '\E') {
6390 0           last;
6391             }
6392             }
6393             }
6394             elsif ($char[$i] eq '\E') {
6395             }
6396              
6397             # \0 --> \0
6398             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
6399             }
6400              
6401             # \g{N}, \g{-N}
6402              
6403             # P.108 Using Simple Patterns
6404             # in Chapter 7: In the World of Regular Expressions
6405             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6406              
6407             # P.221 Capturing
6408             # in Chapter 5: Pattern Matching
6409             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6410              
6411             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6412             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6413             }
6414              
6415             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6416             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6417             }
6418              
6419             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6420             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
6421             }
6422              
6423             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6424             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
6425             }
6426              
6427             # $0 --> $0
6428             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6429 0 0         if ($ignorecase) {
6430 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6431             }
6432             }
6433             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
6434 0 0         if ($ignorecase) {
6435 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6436             }
6437             }
6438              
6439             # $$ --> $$
6440             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6441             }
6442              
6443             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6444             # $1, $2, $3 --> $1, $2, $3 otherwise
6445             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
6446 0           $char[$i] = e_capture($1);
6447 0 0         if ($ignorecase) {
6448 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6449             }
6450             }
6451             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6452 0           $char[$i] = e_capture($1);
6453 0 0         if ($ignorecase) {
6454 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6455             }
6456             }
6457              
6458             # $$foo[ ... ] --> $ $foo->[ ... ]
6459             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6460 0           $char[$i] = e_capture($1.'->'.$2);
6461 0 0         if ($ignorecase) {
6462 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6463             }
6464             }
6465              
6466             # $$foo{ ... } --> $ $foo->{ ... }
6467             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6468 0           $char[$i] = e_capture($1.'->'.$2);
6469 0 0         if ($ignorecase) {
6470 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6471             }
6472             }
6473              
6474             # $$foo
6475             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
6476 0           $char[$i] = e_capture($1);
6477 0 0         if ($ignorecase) {
6478 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6479             }
6480             }
6481              
6482             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin3::PREMATCH()
6483             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
6484 0 0         if ($ignorecase) {
6485 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::PREMATCH())]}';
6486             }
6487             else {
6488 0           $char[$i] = '@{[Char::Elatin3::PREMATCH()]}';
6489             }
6490             }
6491              
6492             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin3::MATCH()
6493             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
6494 0 0         if ($ignorecase) {
6495 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::MATCH())]}';
6496             }
6497             else {
6498 0           $char[$i] = '@{[Char::Elatin3::MATCH()]}';
6499             }
6500             }
6501              
6502             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin3::POSTMATCH()
6503             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
6504 0 0         if ($ignorecase) {
6505 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::POSTMATCH())]}';
6506             }
6507             else {
6508 0           $char[$i] = '@{[Char::Elatin3::POSTMATCH()]}';
6509             }
6510             }
6511              
6512             # ${ foo }
6513             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
6514 0 0         if ($ignorecase) {
6515 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6516             }
6517             }
6518              
6519             # ${ ... }
6520             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
6521 0           $char[$i] = e_capture($1);
6522 0 0         if ($ignorecase) {
6523 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6524             }
6525             }
6526              
6527             # $scalar or @array
6528             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6529 0           $char[$i] = e_string($char[$i]);
6530 0 0         if ($ignorecase) {
6531 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
6532             }
6533             }
6534              
6535             # quote character before ? + * {
6536             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6537 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6538             }
6539             else {
6540 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6541             }
6542             }
6543             }
6544              
6545             # make regexp string
6546 0           my $prematch = '';
6547 0           $modifier =~ tr/i//d;
6548 0 0         if ($left_e > $right_e) {
6549 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6550             }
6551 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6552             }
6553              
6554             #
6555             # escape regexp (s'here'' or s'here''b)
6556             #
6557             sub e_s1_q {
6558 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6559 0   0       $modifier ||= '';
6560              
6561 0           $modifier =~ tr/p//d;
6562 0 0         if ($modifier =~ /([adlu])/oxms) {
6563 0           my $line = 0;
6564 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6565 0 0         if ($filename ne __FILE__) {
6566 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6567 0           last;
6568             }
6569             }
6570 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6571             }
6572              
6573 0           $slash = 'div';
6574              
6575             # literal null string pattern
6576 0 0         if ($string eq '') {
    0          
6577 0           $modifier =~ tr/bB//d;
6578 0           $modifier =~ tr/i//d;
6579 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6580             }
6581              
6582             # with /b /B modifier
6583             elsif ($modifier =~ tr/bB//d) {
6584 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6585             }
6586              
6587             # without /b /B modifier
6588             else {
6589 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6590             }
6591             }
6592              
6593             #
6594             # escape regexp (s'here'')
6595             #
6596             sub e_s1_qt {
6597 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6598              
6599 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6600              
6601             # split regexp
6602 0           my @char = $string =~ /\G(
6603             \[\:\^ [a-z]+ \:\] |
6604             \[\: [a-z]+ \:\] |
6605             \[\^ |
6606             [\$\@\/\\] |
6607             \\? (?:$q_char)
6608             )/oxmsg;
6609              
6610             # unescape character
6611 0           for (my $i=0; $i <= $#char; $i++) {
6612 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6613             }
6614              
6615             # open character class [...]
6616 0           elsif ($char[$i] eq '[') {
6617 0           my $left = $i;
6618 0 0         if ($char[$i+1] eq ']') {
6619 0           $i++;
6620             }
6621 0           while (1) {
6622 0 0         if (++$i > $#char) {
6623 0           die __FILE__, ": Unmatched [] in regexp";
6624             }
6625 0 0         if ($char[$i] eq ']') {
6626 0           my $right = $i;
6627              
6628             # [...]
6629 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
6630              
6631 0           $i = $left;
6632 0           last;
6633             }
6634             }
6635             }
6636              
6637             # open character class [^...]
6638             elsif ($char[$i] eq '[^') {
6639 0           my $left = $i;
6640 0 0         if ($char[$i+1] eq ']') {
6641 0           $i++;
6642             }
6643 0           while (1) {
6644 0 0         if (++$i > $#char) {
6645 0           die __FILE__, ": Unmatched [] in regexp";
6646             }
6647 0 0         if ($char[$i] eq ']') {
6648 0           my $right = $i;
6649              
6650             # [^...]
6651 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6652              
6653 0           $i = $left;
6654 0           last;
6655             }
6656             }
6657             }
6658              
6659             # escape $ @ / and \
6660             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6661 0           $char[$i] = '\\' . $char[$i];
6662             }
6663              
6664             # rewrite character class or escape character
6665             elsif (my $char = character_class($char[$i],$modifier)) {
6666 0           $char[$i] = $char;
6667             }
6668              
6669             # /i modifier
6670             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin3::uc($char[$i]) ne Char::Elatin3::fc($char[$i]))) {
6671 0 0         if (CORE::length(Char::Elatin3::fc($char[$i])) == 1) {
6672 0           $char[$i] = '[' . Char::Elatin3::uc($char[$i]) . Char::Elatin3::fc($char[$i]) . ']';
6673             }
6674             else {
6675 0           $char[$i] = '(?:' . Char::Elatin3::uc($char[$i]) . '|' . Char::Elatin3::fc($char[$i]) . ')';
6676             }
6677             }
6678              
6679             # quote character before ? + * {
6680             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6681 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6682             }
6683             else {
6684 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6685             }
6686             }
6687             }
6688              
6689 0           $modifier =~ tr/i//d;
6690 0           $delimiter = '/';
6691 0           $end_delimiter = '/';
6692 0           my $prematch = '';
6693 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6694             }
6695              
6696             #
6697             # escape regexp (s'here''b)
6698             #
6699             sub e_s1_qb {
6700 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6701              
6702             # split regexp
6703 0           my @char = $string =~ /\G(
6704             \\\\ |
6705             [\$\@\/\\] |
6706             [\x00-\xFF]
6707             )/oxmsg;
6708              
6709             # unescape character
6710 0           for (my $i=0; $i <= $#char; $i++) {
6711 0 0         if (0) {
    0          
6712             }
6713              
6714             # remain \\
6715 0           elsif ($char[$i] eq '\\\\') {
6716             }
6717              
6718             # escape $ @ / and \
6719             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6720 0           $char[$i] = '\\' . $char[$i];
6721             }
6722             }
6723              
6724 0           $delimiter = '/';
6725 0           $end_delimiter = '/';
6726 0           my $prematch = '';
6727 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6728             }
6729              
6730             #
6731             # escape regexp (s''here')
6732             #
6733             sub e_s2_q {
6734 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6735              
6736 0           $slash = 'div';
6737              
6738 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
6739 0           for (my $i=0; $i <= $#char; $i++) {
6740 0 0         if (0) {
    0          
6741             }
6742              
6743             # not escape \\
6744 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6745             }
6746              
6747             # escape $ @ / and \
6748             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6749 0           $char[$i] = '\\' . $char[$i];
6750             }
6751             }
6752              
6753 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6754             }
6755              
6756             #
6757             # escape regexp (s/here/and here/modifier)
6758             #
6759             sub e_sub {
6760 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6761 0   0       $modifier ||= '';
6762              
6763 0           $modifier =~ tr/p//d;
6764 0 0         if ($modifier =~ /([adlu])/oxms) {
6765 0           my $line = 0;
6766 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6767 0 0         if ($filename ne __FILE__) {
6768 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6769 0           last;
6770             }
6771             }
6772 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6773             }
6774              
6775 0 0         if ($variable eq '') {
6776 0           $variable = '$_';
6777 0           $bind_operator = ' =~ ';
6778             }
6779              
6780 0           $slash = 'div';
6781              
6782             # P.128 Start of match (or end of previous match): \G
6783             # P.130 Advanced Use of \G with Perl
6784             # in Chapter 3: Overview of Regular Expression Features and Flavors
6785             # P.312 Iterative Matching: Scalar Context, with /g
6786             # in Chapter 7: Perl
6787             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6788              
6789             # P.181 Where You Left Off: The \G Assertion
6790             # in Chapter 5: Pattern Matching
6791             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6792              
6793             # P.220 Where You Left Off: The \G Assertion
6794             # in Chapter 5: Pattern Matching
6795             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6796              
6797 0           my $e_modifier = $modifier =~ tr/e//d;
6798 0           my $r_modifier = $modifier =~ tr/r//d;
6799              
6800 0           my $my = '';
6801 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
6802 0           $my = $variable;
6803 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
6804 0           $variable =~ s/ = .+ \z//oxms;
6805             }
6806              
6807 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6808 0           $variable_basename =~ s/ \s+ \z//oxms;
6809              
6810             # quote replacement string
6811 0           my $e_replacement = '';
6812 0 0         if ($e_modifier >= 1) {
6813 0           $e_replacement = e_qq('', '', '', $replacement);
6814 0           $e_modifier--;
6815             }
6816             else {
6817 0 0         if ($delimiter2 eq "'") {
6818 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6819             }
6820             else {
6821 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6822             }
6823             }
6824              
6825 0           my $sub = '';
6826              
6827             # with /r
6828 0 0         if ($r_modifier) {
6829 0 0         if (0) {
6830             }
6831              
6832             # s///gr without multibyte anchoring
6833 0           elsif ($modifier =~ /g/oxms) {
6834 0 0         $sub = sprintf(
6835             # 1 2 3 4 5
6836             q,
6837              
6838             $variable, # 1
6839             ($delimiter1 eq "'") ? # 2
6840             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6841             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6842             $s_matched, # 3
6843             $e_replacement, # 4
6844             '$Char::Latin3::re_r=CORE::eval $Char::Latin3::re_r; ' x $e_modifier, # 5
6845             );
6846             }
6847              
6848             # s///r
6849             else {
6850              
6851 0           my $prematch = q{$`};
6852              
6853 0 0         $sub = sprintf(
6854             # 1 2 3 4 5 6 7
6855             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Char::Latin3::re_r=%s; %s"%s$Char::Latin3::re_r$'" } : %s>,
6856              
6857             $variable, # 1
6858             ($delimiter1 eq "'") ? # 2
6859             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6860             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6861             $s_matched, # 3
6862             $e_replacement, # 4
6863             '$Char::Latin3::re_r=CORE::eval $Char::Latin3::re_r; ' x $e_modifier, # 5
6864             $prematch, # 6
6865             $variable, # 7
6866             );
6867             }
6868              
6869             # $var !~ s///r doesn't make sense
6870 0 0         if ($bind_operator =~ / !~ /oxms) {
6871 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6872             }
6873             }
6874              
6875             # without /r
6876             else {
6877 0 0         if (0) {
6878             }
6879              
6880             # s///g without multibyte anchoring
6881 0           elsif ($modifier =~ /g/oxms) {
6882 0 0         $sub = sprintf(
    0          
6883             # 1 2 3 4 5 6 7 8
6884             q,
6885              
6886             $variable, # 1
6887             ($delimiter1 eq "'") ? # 2
6888             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6889             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6890             $s_matched, # 3
6891             $e_replacement, # 4
6892             '$Char::Latin3::re_r=CORE::eval $Char::Latin3::re_r; ' x $e_modifier, # 5
6893             $variable, # 6
6894             $variable, # 7
6895             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6896             );
6897             }
6898              
6899             # s///
6900             else {
6901              
6902 0           my $prematch = q{$`};
6903              
6904 0 0         $sub = sprintf(
    0          
6905              
6906             ($bind_operator =~ / =~ /oxms) ?
6907              
6908             # 1 2 3 4 5 6 7 8
6909             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Char::Latin3::re_r=%s; %s%s="%s$Char::Latin3::re_r$'"; 1 } : undef> :
6910              
6911             # 1 2 3 4 5 6 7 8
6912             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Char::Latin3::re_r=%s; %s%s="%s$Char::Latin3::re_r$'"; undef }>,
6913              
6914             $variable, # 1
6915             $bind_operator, # 2
6916             ($delimiter1 eq "'") ? # 3
6917             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6918             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6919             $s_matched, # 4
6920             $e_replacement, # 5
6921             '$Char::Latin3::re_r=CORE::eval $Char::Latin3::re_r; ' x $e_modifier, # 6
6922             $variable, # 7
6923             $prematch, # 8
6924             );
6925             }
6926             }
6927              
6928             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6929 0 0         if ($my ne '') {
6930 0           $sub = "($my, $sub)[1]";
6931             }
6932              
6933             # clear s/// variable
6934 0           $sub_variable = '';
6935 0           $bind_operator = '';
6936              
6937 0           return $sub;
6938             }
6939              
6940             #
6941             # escape regexp of split qr//
6942             #
6943             sub e_split {
6944 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6945 0   0       $modifier ||= '';
6946              
6947 0           $modifier =~ tr/p//d;
6948 0 0         if ($modifier =~ /([adlu])/oxms) {
6949 0           my $line = 0;
6950 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6951 0 0         if ($filename ne __FILE__) {
6952 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6953 0           last;
6954             }
6955             }
6956 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6957             }
6958              
6959 0           $slash = 'div';
6960              
6961             # /b /B modifier
6962 0 0         if ($modifier =~ tr/bB//d) {
6963 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6964             }
6965              
6966 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6967 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6968              
6969             # split regexp
6970 0           my @char = $string =~ /\G(
6971             \\o\{ [0-7]+ \} |
6972             \\ [0-7]{2,3} |
6973             \\x\{ [0-9A-Fa-f]+ \} |
6974             \\x [0-9A-Fa-f]{1,2} |
6975             \\c [\x40-\x5F] |
6976             \\N\{ [^0-9\}][^\}]* \} |
6977             \\p\{ [^0-9\}][^\}]* \} |
6978             \\P\{ [^0-9\}][^\}]* \} |
6979             \\ (?:$q_char) |
6980             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6981             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6982             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6983             [\$\@] $qq_variable |
6984             \$ \s* \d+ |
6985             \$ \s* \{ \s* \d+ \s* \} |
6986             \$ \$ (?![\w\{]) |
6987             \$ \s* \$ \s* $qq_variable |
6988             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6989             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6990             \[\^ |
6991             \(\? |
6992             (?:$q_char)
6993             )/oxmsg;
6994              
6995 0           my $left_e = 0;
6996 0           my $right_e = 0;
6997 0           for (my $i=0; $i <= $#char; $i++) {
6998              
6999             # "\L\u" --> "\u\L"
7000 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
7001 0           @char[$i,$i+1] = @char[$i+1,$i];
7002             }
7003              
7004             # "\U\l" --> "\l\U"
7005             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7006 0           @char[$i,$i+1] = @char[$i+1,$i];
7007             }
7008              
7009             # octal escape sequence
7010             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7011 0           $char[$i] = Char::Elatin3::octchr($1);
7012             }
7013              
7014             # hexadecimal escape sequence
7015             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7016 0           $char[$i] = Char::Elatin3::hexchr($1);
7017             }
7018              
7019             # \N{CHARNAME} --> N\{CHARNAME}
7020             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7021 0           $char[$i] = $1 . '\\' . $2;
7022             }
7023              
7024             # \p{PROPERTY} --> p\{PROPERTY}
7025             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7026 0           $char[$i] = $1 . '\\' . $2;
7027             }
7028              
7029             # \P{PROPERTY} --> P\{PROPERTY}
7030             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7031 0           $char[$i] = $1 . '\\' . $2;
7032             }
7033              
7034             # \p, \P, \X --> p, P, X
7035             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7036 0           $char[$i] = $1;
7037             }
7038              
7039 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          
7040             }
7041              
7042             # join separated multiple-octet
7043 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7044 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        
7045 0           $char[$i] .= join '', splice @char, $i+1, 3;
7046             }
7047             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)) {
7048 0           $char[$i] .= join '', splice @char, $i+1, 2;
7049             }
7050             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)) {
7051 0           $char[$i] .= join '', splice @char, $i+1, 1;
7052             }
7053             }
7054              
7055             # open character class [...]
7056             elsif ($char[$i] eq '[') {
7057 0           my $left = $i;
7058 0 0         if ($char[$i+1] eq ']') {
7059 0           $i++;
7060             }
7061 0           while (1) {
7062 0 0         if (++$i > $#char) {
7063 0           die __FILE__, ": Unmatched [] in regexp";
7064             }
7065 0 0         if ($char[$i] eq ']') {
7066 0           my $right = $i;
7067              
7068             # [...]
7069 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7070 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin3::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7071             }
7072             else {
7073 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
7074             }
7075              
7076 0           $i = $left;
7077 0           last;
7078             }
7079             }
7080             }
7081              
7082             # open character class [^...]
7083             elsif ($char[$i] eq '[^') {
7084 0           my $left = $i;
7085 0 0         if ($char[$i+1] eq ']') {
7086 0           $i++;
7087             }
7088 0           while (1) {
7089 0 0         if (++$i > $#char) {
7090 0           die __FILE__, ": Unmatched [] in regexp";
7091             }
7092 0 0         if ($char[$i] eq ']') {
7093 0           my $right = $i;
7094              
7095             # [^...]
7096 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7097 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin3::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7098             }
7099             else {
7100 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7101             }
7102              
7103 0           $i = $left;
7104 0           last;
7105             }
7106             }
7107             }
7108              
7109             # rewrite character class or escape character
7110             elsif (my $char = character_class($char[$i],$modifier)) {
7111 0           $char[$i] = $char;
7112             }
7113              
7114             # P.794 29.2.161. split
7115             # in Chapter 29: Functions
7116             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7117              
7118             # P.951 split
7119             # in Chapter 27: Functions
7120             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7121              
7122             # said "The //m modifier is assumed when you split on the pattern /^/",
7123             # but perl5.008 is not so. Therefore, this software adds //m.
7124             # (and so on)
7125              
7126             # split(m/^/) --> split(m/^/m)
7127             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7128 0           $modifier .= 'm';
7129             }
7130              
7131             # /i modifier
7132             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin3::uc($char[$i]) ne Char::Elatin3::fc($char[$i]))) {
7133 0 0         if (CORE::length(Char::Elatin3::fc($char[$i])) == 1) {
7134 0           $char[$i] = '[' . Char::Elatin3::uc($char[$i]) . Char::Elatin3::fc($char[$i]) . ']';
7135             }
7136             else {
7137 0           $char[$i] = '(?:' . Char::Elatin3::uc($char[$i]) . '|' . Char::Elatin3::fc($char[$i]) . ')';
7138             }
7139             }
7140              
7141             # \u \l \U \L \F \Q \E
7142             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7143 0 0         if ($right_e < $left_e) {
7144 0           $char[$i] = '\\' . $char[$i];
7145             }
7146             }
7147             elsif ($char[$i] eq '\u') {
7148 0           $char[$i] = '@{[Char::Elatin3::ucfirst qq<';
7149 0           $left_e++;
7150             }
7151             elsif ($char[$i] eq '\l') {
7152 0           $char[$i] = '@{[Char::Elatin3::lcfirst qq<';
7153 0           $left_e++;
7154             }
7155             elsif ($char[$i] eq '\U') {
7156 0           $char[$i] = '@{[Char::Elatin3::uc qq<';
7157 0           $left_e++;
7158             }
7159             elsif ($char[$i] eq '\L') {
7160 0           $char[$i] = '@{[Char::Elatin3::lc qq<';
7161 0           $left_e++;
7162             }
7163             elsif ($char[$i] eq '\F') {
7164 0           $char[$i] = '@{[Char::Elatin3::fc qq<';
7165 0           $left_e++;
7166             }
7167             elsif ($char[$i] eq '\Q') {
7168 0           $char[$i] = '@{[CORE::quotemeta qq<';
7169 0           $left_e++;
7170             }
7171             elsif ($char[$i] eq '\E') {
7172 0 0         if ($right_e < $left_e) {
7173 0           $char[$i] = '>]}';
7174 0           $right_e++;
7175             }
7176             else {
7177 0           $char[$i] = '';
7178             }
7179             }
7180             elsif ($char[$i] eq '\Q') {
7181 0           while (1) {
7182 0 0         if (++$i > $#char) {
7183 0           last;
7184             }
7185 0 0         if ($char[$i] eq '\E') {
7186 0           last;
7187             }
7188             }
7189             }
7190             elsif ($char[$i] eq '\E') {
7191             }
7192              
7193             # $0 --> $0
7194             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7195 0 0         if ($ignorecase) {
7196 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7197             }
7198             }
7199             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
7200 0 0         if ($ignorecase) {
7201 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7202             }
7203             }
7204              
7205             # $$ --> $$
7206             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7207             }
7208              
7209             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7210             # $1, $2, $3 --> $1, $2, $3 otherwise
7211             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
7212 0           $char[$i] = e_capture($1);
7213 0 0         if ($ignorecase) {
7214 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7215             }
7216             }
7217             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
7218 0           $char[$i] = e_capture($1);
7219 0 0         if ($ignorecase) {
7220 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7221             }
7222             }
7223              
7224             # $$foo[ ... ] --> $ $foo->[ ... ]
7225             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7226 0           $char[$i] = e_capture($1.'->'.$2);
7227 0 0         if ($ignorecase) {
7228 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7229             }
7230             }
7231              
7232             # $$foo{ ... } --> $ $foo->{ ... }
7233             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7234 0           $char[$i] = e_capture($1.'->'.$2);
7235 0 0         if ($ignorecase) {
7236 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7237             }
7238             }
7239              
7240             # $$foo
7241             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
7242 0           $char[$i] = e_capture($1);
7243 0 0         if ($ignorecase) {
7244 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7245             }
7246             }
7247              
7248             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin3::PREMATCH()
7249             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
7250 0 0         if ($ignorecase) {
7251 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::PREMATCH())]}';
7252             }
7253             else {
7254 0           $char[$i] = '@{[Char::Elatin3::PREMATCH()]}';
7255             }
7256             }
7257              
7258             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin3::MATCH()
7259             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
7260 0 0         if ($ignorecase) {
7261 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::MATCH())]}';
7262             }
7263             else {
7264 0           $char[$i] = '@{[Char::Elatin3::MATCH()]}';
7265             }
7266             }
7267              
7268             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin3::POSTMATCH()
7269             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
7270 0 0         if ($ignorecase) {
7271 0           $char[$i] = '@{[Char::Elatin3::ignorecase(Char::Elatin3::POSTMATCH())]}';
7272             }
7273             else {
7274 0           $char[$i] = '@{[Char::Elatin3::POSTMATCH()]}';
7275             }
7276             }
7277              
7278             # ${ foo }
7279             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
7280 0 0         if ($ignorecase) {
7281 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $1 . ')]}';
7282             }
7283             }
7284              
7285             # ${ ... }
7286             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
7287 0           $char[$i] = e_capture($1);
7288 0 0         if ($ignorecase) {
7289 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7290             }
7291             }
7292              
7293             # $scalar or @array
7294             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7295 0           $char[$i] = e_string($char[$i]);
7296 0 0         if ($ignorecase) {
7297 0           $char[$i] = '@{[Char::Elatin3::ignorecase(' . $char[$i] . ')]}';
7298             }
7299             }
7300              
7301             # quote character before ? + * {
7302             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7303 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7304             }
7305             else {
7306 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7307             }
7308             }
7309             }
7310              
7311             # make regexp string
7312 0           $modifier =~ tr/i//d;
7313 0 0         if ($left_e > $right_e) {
7314 0           return join '', 'Char::Elatin3::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7315             }
7316 0           return join '', 'Char::Elatin3::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7317             }
7318              
7319             #
7320             # escape regexp of split qr''
7321             #
7322             sub e_split_q {
7323 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7324 0   0       $modifier ||= '';
7325              
7326 0           $modifier =~ tr/p//d;
7327 0 0         if ($modifier =~ /([adlu])/oxms) {
7328 0           my $line = 0;
7329 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7330 0 0         if ($filename ne __FILE__) {
7331 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7332 0           last;
7333             }
7334             }
7335 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7336             }
7337              
7338 0           $slash = 'div';
7339              
7340             # /b /B modifier
7341 0 0         if ($modifier =~ tr/bB//d) {
7342 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7343             }
7344              
7345 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7346              
7347             # split regexp
7348 0           my @char = $string =~ /\G(
7349             \[\:\^ [a-z]+ \:\] |
7350             \[\: [a-z]+ \:\] |
7351             \[\^ |
7352             \\? (?:$q_char)
7353             )/oxmsg;
7354              
7355             # unescape character
7356 0           for (my $i=0; $i <= $#char; $i++) {
7357 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7358             }
7359              
7360             # open character class [...]
7361 0           elsif ($char[$i] eq '[') {
7362 0           my $left = $i;
7363 0 0         if ($char[$i+1] eq ']') {
7364 0           $i++;
7365             }
7366 0           while (1) {
7367 0 0         if (++$i > $#char) {
7368 0           die __FILE__, ": Unmatched [] in regexp";
7369             }
7370 0 0         if ($char[$i] eq ']') {
7371 0           my $right = $i;
7372              
7373             # [...]
7374 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_qr(@char[$left+1..$right-1], $modifier);
7375              
7376 0           $i = $left;
7377 0           last;
7378             }
7379             }
7380             }
7381              
7382             # open character class [^...]
7383             elsif ($char[$i] eq '[^') {
7384 0           my $left = $i;
7385 0 0         if ($char[$i+1] eq ']') {
7386 0           $i++;
7387             }
7388 0           while (1) {
7389 0 0         if (++$i > $#char) {
7390 0           die __FILE__, ": Unmatched [] in regexp";
7391             }
7392 0 0         if ($char[$i] eq ']') {
7393 0           my $right = $i;
7394              
7395             # [^...]
7396 0           splice @char, $left, $right-$left+1, Char::Elatin3::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7397              
7398 0           $i = $left;
7399 0           last;
7400             }
7401             }
7402             }
7403              
7404             # rewrite character class or escape character
7405             elsif (my $char = character_class($char[$i],$modifier)) {
7406 0           $char[$i] = $char;
7407             }
7408              
7409             # split(m/^/) --> split(m/^/m)
7410             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7411 0           $modifier .= 'm';
7412             }
7413              
7414             # /i modifier
7415             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin3::uc($char[$i]) ne Char::Elatin3::fc($char[$i]))) {
7416 0 0         if (CORE::length(Char::Elatin3::fc($char[$i])) == 1) {
7417 0           $char[$i] = '[' . Char::Elatin3::uc($char[$i]) . Char::Elatin3::fc($char[$i]) . ']';
7418             }
7419             else {
7420 0           $char[$i] = '(?:' . Char::Elatin3::uc($char[$i]) . '|' . Char::Elatin3::fc($char[$i]) . ')';
7421             }
7422             }
7423              
7424             # quote character before ? + * {
7425             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7426 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7427             }
7428             else {
7429 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7430             }
7431             }
7432             }
7433              
7434 0           $modifier =~ tr/i//d;
7435 0           return join '', 'Char::Elatin3::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7436             }
7437              
7438             #
7439             # instead of Carp::carp
7440             #
7441             sub carp {
7442 0     0 0   my($package,$filename,$line) = caller(1);
7443 0           print STDERR "@_ at $filename line $line.\n";
7444             }
7445              
7446             #
7447             # instead of Carp::croak
7448             #
7449             sub croak {
7450 0     0 0   my($package,$filename,$line) = caller(1);
7451 0           print STDERR "@_ at $filename line $line.\n";
7452 0           die "\n";
7453             }
7454              
7455             #
7456             # instead of Carp::cluck
7457             #
7458             sub cluck {
7459 0     0 0   my $i = 0;
7460 0           my @cluck = ();
7461 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7462 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7463 0           $i++;
7464             }
7465 0           print STDERR CORE::reverse @cluck;
7466 0           print STDERR "\n";
7467 0           carp @_;
7468             }
7469              
7470             #
7471             # instead of Carp::confess
7472             #
7473             sub confess {
7474 0     0 0   my $i = 0;
7475 0           my @confess = ();
7476 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7477 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7478 0           $i++;
7479             }
7480 0           print STDERR CORE::reverse @confess;
7481 0           print STDERR "\n";
7482 0           croak @_;
7483             }
7484              
7485             1;
7486              
7487             __END__