File Coverage

Char/Elatin7.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::Elatin7;
5             ######################################################################
6             #
7             # Char::Elatin7 - Run-time routines for Char/Latin7.pm
8             #
9             # http://search.cpan.org/dist/Char-Latin7/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
12             ######################################################################
13              
14 197     197   12871 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         773  
  197         10864  
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   15332 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1368  
  197         338  
  197         38006  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 197 50   197   2154 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 197         282 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 197         33693 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   13762 CORE::eval q{
  197     197   1387  
  197     68   539  
  197         30295  
  68         11679  
  71         13185  
  48         8718  
  65         12124  
  70         11980  
  72         13031  
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       118377 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   498 my $genpkg = "Symbol::";
62 197         10691 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::Elatin7::index($name, '::') == -1) && (Char::Elatin7::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   446 if (CORE::eval { local $@; CORE::require strict }) {
  197         569  
  197         2160  
110 197         28541 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   13400 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  197     197   1152  
  197         347  
  197         12517  
140 197     197   33945 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  197     197   1055  
  197         307  
  197         14745  
141 197     197   33980 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  197     197   1075  
  197         306  
  197         14997  
142              
143             #
144             # Latin-7 character range per length
145             #
146             my %range_tr = ();
147              
148             #
149             # alias of encoding name
150             #
151 197     197   11775 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  197     197   1049  
  197         320  
  197         411094  
152              
153             #
154             # Latin-7 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 Elatin7 \z/oxms) {
170             %range_tr = (
171             1 => [ [0x00..0xFF],
172             ],
173             );
174             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-13 | iec[- ]?8859-13 | latin-?7 ) \b /oxmsi;
175              
176             %lc = (%lc,
177             "\xA8" => "\xB8", # LATIN LETTER O WITH STROKE
178             "\xAA" => "\xBA", # LATIN LETTER R WITH CEDILLA
179             "\xAF" => "\xBF", # LATIN LETTER AE
180             "\xC0" => "\xE0", # LATIN LETTER A WITH OGONEK
181             "\xC1" => "\xE1", # LATIN LETTER I WITH OGONEK
182             "\xC2" => "\xE2", # LATIN LETTER A WITH MACRON
183             "\xC3" => "\xE3", # LATIN LETTER C WITH ACUTE
184             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
185             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
186             "\xC6" => "\xE6", # LATIN LETTER E WITH OGONEK
187             "\xC7" => "\xE7", # LATIN LETTER E WITH MACRON
188             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
189             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
190             "\xCA" => "\xEA", # LATIN LETTER Z WITH ACUTE
191             "\xCB" => "\xEB", # LATIN LETTER E WITH DOT ABOVE
192             "\xCC" => "\xEC", # LATIN LETTER G WITH CEDILLA
193             "\xCD" => "\xED", # LATIN LETTER K WITH CEDILLA
194             "\xCE" => "\xEE", # LATIN LETTER I WITH MACRON
195             "\xCF" => "\xEF", # LATIN LETTER L WITH CEDILLA
196             "\xD0" => "\xF0", # LATIN LETTER S WITH CARON
197             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
198             "\xD2" => "\xF2", # LATIN LETTER N WITH CEDILLA
199             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
200             "\xD4" => "\xF4", # LATIN LETTER O WITH MACRON
201             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
202             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
203             "\xD8" => "\xF8", # LATIN LETTER U WITH OGONEK
204             "\xD9" => "\xF9", # LATIN LETTER L WITH STROKE
205             "\xDA" => "\xFA", # LATIN LETTER S WITH ACUTE
206             "\xDB" => "\xFB", # LATIN LETTER U WITH MACRON
207             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
208             "\xDD" => "\xFD", # LATIN LETTER Z WITH DOT ABOVE
209             "\xDE" => "\xFE", # LATIN LETTER Z WITH CARON
210             );
211              
212             %uc = (%uc,
213             "\xB8" => "\xA8", # LATIN LETTER O WITH STROKE
214             "\xBA" => "\xAA", # LATIN LETTER R WITH CEDILLA
215             "\xBF" => "\xAF", # LATIN LETTER AE
216             "\xE0" => "\xC0", # LATIN LETTER A WITH OGONEK
217             "\xE1" => "\xC1", # LATIN LETTER I WITH OGONEK
218             "\xE2" => "\xC2", # LATIN LETTER A WITH MACRON
219             "\xE3" => "\xC3", # LATIN LETTER C WITH ACUTE
220             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
221             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
222             "\xE6" => "\xC6", # LATIN LETTER E WITH OGONEK
223             "\xE7" => "\xC7", # LATIN LETTER E WITH MACRON
224             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
225             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
226             "\xEA" => "\xCA", # LATIN LETTER Z WITH ACUTE
227             "\xEB" => "\xCB", # LATIN LETTER E WITH DOT ABOVE
228             "\xEC" => "\xCC", # LATIN LETTER G WITH CEDILLA
229             "\xED" => "\xCD", # LATIN LETTER K WITH CEDILLA
230             "\xEE" => "\xCE", # LATIN LETTER I WITH MACRON
231             "\xEF" => "\xCF", # LATIN LETTER L WITH CEDILLA
232             "\xF0" => "\xD0", # LATIN LETTER S WITH CARON
233             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
234             "\xF2" => "\xD2", # LATIN LETTER N WITH CEDILLA
235             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
236             "\xF4" => "\xD4", # LATIN LETTER O WITH MACRON
237             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
238             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
239             "\xF8" => "\xD8", # LATIN LETTER U WITH OGONEK
240             "\xF9" => "\xD9", # LATIN LETTER L WITH STROKE
241             "\xFA" => "\xDA", # LATIN LETTER S WITH ACUTE
242             "\xFB" => "\xDB", # LATIN LETTER U WITH MACRON
243             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
244             "\xFD" => "\xDD", # LATIN LETTER Z WITH DOT ABOVE
245             "\xFE" => "\xDE", # LATIN LETTER Z WITH CARON
246             );
247              
248             %fc = (%fc,
249             "\xA8" => "\xB8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
250             "\xAA" => "\xBA", # LATIN CAPITAL LETTER R WITH CEDILLA --> LATIN SMALL LETTER R WITH CEDILLA
251             "\xAF" => "\xBF", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
252             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
253             "\xC1" => "\xE1", # LATIN CAPITAL LETTER I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
254             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
255             "\xC3" => "\xE3", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
256             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
257             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
258             "\xC6" => "\xE6", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
259             "\xC7" => "\xE7", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
260             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
261             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
262             "\xCA" => "\xEA", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
263             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
264             "\xCC" => "\xEC", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
265             "\xCD" => "\xED", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
266             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
267             "\xCF" => "\xEF", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
268             "\xD0" => "\xF0", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
269             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
270             "\xD2" => "\xF2", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
271             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
272             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
273             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
274             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
275             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
276             "\xD9" => "\xF9", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
277             "\xDA" => "\xFA", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
278             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
279             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
280             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
281             "\xDE" => "\xFE", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
282             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
283             );
284             }
285              
286             else {
287             croak "Don't know my package name '@{[__PACKAGE__]}'";
288             }
289              
290             #
291             # @ARGV wildcard globbing
292             #
293             sub import {
294              
295 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
296 0         0 my @argv = ();
297 0         0 for (@ARGV) {
298              
299             # has space
300 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
301 0 0       0 if (my @glob = Char::Elatin7::glob(qq{"$_"})) {
302 0         0 push @argv, @glob;
303             }
304             else {
305 0         0 push @argv, $_;
306             }
307             }
308              
309             # has wildcard metachar
310             elsif (/\A (?:$q_char)*? [*?] /oxms) {
311 0 0       0 if (my @glob = Char::Elatin7::glob($_)) {
312 0         0 push @argv, @glob;
313             }
314             else {
315 0         0 push @argv, $_;
316             }
317             }
318              
319             # no wildcard globbing
320             else {
321 0         0 push @argv, $_;
322             }
323             }
324 0         0 @ARGV = @argv;
325             }
326             }
327              
328             # P.230 Care with Prototypes
329             # in Chapter 6: Subroutines
330             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
331             #
332             # If you aren't careful, you can get yourself into trouble with prototypes.
333             # But if you are careful, you can do a lot of neat things with them. This is
334             # all very powerful, of course, and should only be used in moderation to make
335             # the world a better place.
336              
337             # P.332 Care with Prototypes
338             # in Chapter 7: Subroutines
339             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
340             #
341             # If you aren't careful, you can get yourself into trouble with prototypes.
342             # But if you are careful, you can do a lot of neat things with them. This is
343             # all very powerful, of course, and should only be used in moderation to make
344             # the world a better place.
345              
346             #
347             # Prototypes of subroutines
348             #
349 0     0   0 sub unimport {}
350             sub Char::Elatin7::split(;$$$);
351             sub Char::Elatin7::tr($$$$;$);
352             sub Char::Elatin7::chop(@);
353             sub Char::Elatin7::index($$;$);
354             sub Char::Elatin7::rindex($$;$);
355             sub Char::Elatin7::lcfirst(@);
356             sub Char::Elatin7::lcfirst_();
357             sub Char::Elatin7::lc(@);
358             sub Char::Elatin7::lc_();
359             sub Char::Elatin7::ucfirst(@);
360             sub Char::Elatin7::ucfirst_();
361             sub Char::Elatin7::uc(@);
362             sub Char::Elatin7::uc_();
363             sub Char::Elatin7::fc(@);
364             sub Char::Elatin7::fc_();
365             sub Char::Elatin7::ignorecase;
366             sub Char::Elatin7::classic_character_class;
367             sub Char::Elatin7::capture;
368             sub Char::Elatin7::chr(;$);
369             sub Char::Elatin7::chr_();
370             sub Char::Elatin7::glob($);
371             sub Char::Elatin7::glob_();
372              
373             sub Char::Latin7::ord(;$);
374             sub Char::Latin7::ord_();
375             sub Char::Latin7::reverse(@);
376             sub Char::Latin7::getc(;*@);
377             sub Char::Latin7::length(;$);
378             sub Char::Latin7::substr($$;$$);
379             sub Char::Latin7::index($$;$);
380             sub Char::Latin7::rindex($$;$);
381             sub Char::Latin7::escape(;$);
382              
383             #
384             # Regexp work
385             #
386 197     197   18002 BEGIN { CORE::eval q{ use vars qw(
  197     197   1391  
  197         337  
  197         90160  
387             $Char::Latin7::re_a
388             $Char::Latin7::re_t
389             $Char::Latin7::re_n
390             $Char::Latin7::re_r
391             ) } }
392              
393             #
394             # Character class
395             #
396 197     197   19630 BEGIN { CORE::eval q{ use vars qw(
  197     197   1190  
  197         365  
  197         3213962  
397             $dot
398             $dot_s
399             $eD
400             $eS
401             $eW
402             $eH
403             $eV
404             $eR
405             $eN
406             $not_alnum
407             $not_alpha
408             $not_ascii
409             $not_blank
410             $not_cntrl
411             $not_digit
412             $not_graph
413             $not_lower
414             $not_lower_i
415             $not_print
416             $not_punct
417             $not_space
418             $not_upper
419             $not_upper_i
420             $not_word
421             $not_xdigit
422             $eb
423             $eB
424             ) } }
425              
426             ${Char::Elatin7::dot} = qr{(?:[^\x0A])};
427             ${Char::Elatin7::dot_s} = qr{(?:[\x00-\xFF])};
428             ${Char::Elatin7::eD} = qr{(?:[^0-9])};
429              
430             # Vertical tabs are now whitespace
431             # \s in a regex now matches a vertical tab in all circumstances.
432             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
433             # ${Char::Elatin7::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
434             # ${Char::Elatin7::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
435             ${Char::Elatin7::eS} = qr{(?:[^\s])};
436              
437             ${Char::Elatin7::eW} = qr{(?:[^0-9A-Z_a-z])};
438             ${Char::Elatin7::eH} = qr{(?:[^\x09\x20])};
439             ${Char::Elatin7::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
440             ${Char::Elatin7::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
441             ${Char::Elatin7::eN} = qr{(?:[^\x0A])};
442             ${Char::Elatin7::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
443             ${Char::Elatin7::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
444             ${Char::Elatin7::not_ascii} = qr{(?:[^\x00-\x7F])};
445             ${Char::Elatin7::not_blank} = qr{(?:[^\x09\x20])};
446             ${Char::Elatin7::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
447             ${Char::Elatin7::not_digit} = qr{(?:[^\x30-\x39])};
448             ${Char::Elatin7::not_graph} = qr{(?:[^\x21-\x7F])};
449             ${Char::Elatin7::not_lower} = qr{(?:[^\x61-\x7A])};
450             ${Char::Elatin7::not_lower_i} = qr{(?:[\x00-\xFF])};
451             ${Char::Elatin7::not_print} = qr{(?:[^\x20-\x7F])};
452             ${Char::Elatin7::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
453             ${Char::Elatin7::not_space} = qr{(?:[^\s\x0B])};
454             ${Char::Elatin7::not_upper} = qr{(?:[^\x41-\x5A])};
455             ${Char::Elatin7::not_upper_i} = qr{(?:[\x00-\xFF])};
456             ${Char::Elatin7::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
457             ${Char::Elatin7::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
458             ${Char::Elatin7::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))};
459             ${Char::Elatin7::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]))};
460              
461             # avoid: Name "Char::Elatin7::foo" used only once: possible typo at here.
462             ${Char::Elatin7::dot} = ${Char::Elatin7::dot};
463             ${Char::Elatin7::dot_s} = ${Char::Elatin7::dot_s};
464             ${Char::Elatin7::eD} = ${Char::Elatin7::eD};
465             ${Char::Elatin7::eS} = ${Char::Elatin7::eS};
466             ${Char::Elatin7::eW} = ${Char::Elatin7::eW};
467             ${Char::Elatin7::eH} = ${Char::Elatin7::eH};
468             ${Char::Elatin7::eV} = ${Char::Elatin7::eV};
469             ${Char::Elatin7::eR} = ${Char::Elatin7::eR};
470             ${Char::Elatin7::eN} = ${Char::Elatin7::eN};
471             ${Char::Elatin7::not_alnum} = ${Char::Elatin7::not_alnum};
472             ${Char::Elatin7::not_alpha} = ${Char::Elatin7::not_alpha};
473             ${Char::Elatin7::not_ascii} = ${Char::Elatin7::not_ascii};
474             ${Char::Elatin7::not_blank} = ${Char::Elatin7::not_blank};
475             ${Char::Elatin7::not_cntrl} = ${Char::Elatin7::not_cntrl};
476             ${Char::Elatin7::not_digit} = ${Char::Elatin7::not_digit};
477             ${Char::Elatin7::not_graph} = ${Char::Elatin7::not_graph};
478             ${Char::Elatin7::not_lower} = ${Char::Elatin7::not_lower};
479             ${Char::Elatin7::not_lower_i} = ${Char::Elatin7::not_lower_i};
480             ${Char::Elatin7::not_print} = ${Char::Elatin7::not_print};
481             ${Char::Elatin7::not_punct} = ${Char::Elatin7::not_punct};
482             ${Char::Elatin7::not_space} = ${Char::Elatin7::not_space};
483             ${Char::Elatin7::not_upper} = ${Char::Elatin7::not_upper};
484             ${Char::Elatin7::not_upper_i} = ${Char::Elatin7::not_upper_i};
485             ${Char::Elatin7::not_word} = ${Char::Elatin7::not_word};
486             ${Char::Elatin7::not_xdigit} = ${Char::Elatin7::not_xdigit};
487             ${Char::Elatin7::eb} = ${Char::Elatin7::eb};
488             ${Char::Elatin7::eB} = ${Char::Elatin7::eB};
489              
490             #
491             # Latin-7 split
492             #
493             sub Char::Elatin7::split(;$$$) {
494              
495             # P.794 29.2.161. split
496             # in Chapter 29: Functions
497             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
498              
499             # P.951 split
500             # in Chapter 27: Functions
501             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
502              
503 0     0 0 0 my $pattern = $_[0];
504 0         0 my $string = $_[1];
505 0         0 my $limit = $_[2];
506              
507             # if $pattern is also omitted or is the literal space, " "
508 0 0       0 if (not defined $pattern) {
509 0         0 $pattern = ' ';
510             }
511              
512             # if $string is omitted, the function splits the $_ string
513 0 0       0 if (not defined $string) {
514 0 0       0 if (defined $_) {
515 0         0 $string = $_;
516             }
517             else {
518 0         0 $string = '';
519             }
520             }
521              
522 0         0 my @split = ();
523              
524             # when string is empty
525 0 0       0 if ($string eq '') {
    0          
526              
527             # resulting list value in list context
528 0 0       0 if (wantarray) {
529 0         0 return @split;
530             }
531              
532             # count of substrings in scalar context
533             else {
534 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
535 0         0 @_ = @split;
536 0         0 return scalar @_;
537             }
538             }
539              
540             # split's first argument is more consistently interpreted
541             #
542             # After some changes earlier in v5.17, split's behavior has been simplified:
543             # if the PATTERN argument evaluates to a string containing one space, it is
544             # treated the way that a literal string containing one space once was.
545             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
546              
547             # if $pattern is also omitted or is the literal space, " ", the function splits
548             # on whitespace, /\s+/, after skipping any leading whitespace
549             # (and so on)
550              
551             elsif ($pattern eq ' ') {
552 0 0       0 if (not defined $limit) {
553 0         0 return CORE::split(' ', $string);
554             }
555             else {
556 0         0 return CORE::split(' ', $string, $limit);
557             }
558             }
559              
560             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
561 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
562              
563             # a pattern capable of matching either the null string or something longer than the
564             # null string will split the value of $string into separate characters wherever it
565             # matches the null string between characters
566             # (and so on)
567              
568 0 0       0 if ('' =~ / \A $pattern \z /xms) {
569 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
570 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
571              
572             # P.1024 Appendix W.10 Multibyte Processing
573             # of ISBN 1-56592-224-7 CJKV Information Processing
574             # (and so on)
575              
576             # the //m modifier is assumed when you split on the pattern /^/
577             # (and so on)
578              
579             # V
580 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
581              
582             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
583             # is included in the resulting list, interspersed with the fields that are ordinarily returned
584             # (and so on)
585              
586 0         0 local $@;
587 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
588 0         0 push @split, CORE::eval('$' . $digit);
589             }
590             }
591             }
592              
593             else {
594 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
595              
596             # V
597 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
598 0         0 local $@;
599 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
600 0         0 push @split, CORE::eval('$' . $digit);
601             }
602             }
603             }
604             }
605              
606             elsif ($limit > 0) {
607 0 0       0 if ('' =~ / \A $pattern \z /xms) {
608 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
609 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
610              
611             # V
612 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
613 0         0 local $@;
614 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
615 0         0 push @split, CORE::eval('$' . $digit);
616             }
617             }
618             }
619             }
620             else {
621 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
622 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
623              
624             # V
625 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
626 0         0 local $@;
627 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
628 0         0 push @split, CORE::eval('$' . $digit);
629             }
630             }
631             }
632             }
633             }
634              
635 0 0       0 if (CORE::length($string) > 0) {
636 0         0 push @split, $string;
637             }
638              
639             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
640 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
641 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
642 0         0 pop @split;
643             }
644             }
645              
646             # resulting list value in list context
647 0 0       0 if (wantarray) {
648 0         0 return @split;
649             }
650              
651             # count of substrings in scalar context
652             else {
653 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
654 0         0 @_ = @split;
655 0         0 return scalar @_;
656             }
657             }
658              
659             #
660             # get last subexpression offsets
661             #
662             sub _last_subexpression_offsets {
663 0     0   0 my $pattern = $_[0];
664              
665             # remove comment
666 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
667              
668 0         0 my $modifier = '';
669 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
670 0         0 $modifier = $1;
671 0         0 $modifier =~ s/-[A-Za-z]*//;
672             }
673              
674             # with /x modifier
675 0         0 my @char = ();
676 0 0       0 if ($modifier =~ /x/oxms) {
677 0         0 @char = $pattern =~ /\G(
678             \\ (?:$q_char) |
679             \# (?:$q_char)*? $ |
680             \[ (?: \\\] | (?:$q_char))+? \] |
681             \(\? |
682             (?:$q_char)
683             )/oxmsg;
684             }
685              
686             # without /x modifier
687             else {
688 0         0 @char = $pattern =~ /\G(
689             \\ (?:$q_char) |
690             \[ (?: \\\] | (?:$q_char))+? \] |
691             \(\? |
692             (?:$q_char)
693             )/oxmsg;
694             }
695              
696 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
697             }
698              
699             #
700             # Latin-7 transliteration (tr///)
701             #
702             sub Char::Elatin7::tr($$$$;$) {
703              
704 0     0 0 0 my $bind_operator = $_[1];
705 0         0 my $searchlist = $_[2];
706 0         0 my $replacementlist = $_[3];
707 0   0     0 my $modifier = $_[4] || '';
708              
709 0 0       0 if ($modifier =~ /r/oxms) {
710 0 0       0 if ($bind_operator =~ / !~ /oxms) {
711 0         0 croak "Using !~ with tr///r doesn't make sense";
712             }
713             }
714              
715 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
716 0         0 my @searchlist = _charlist_tr($searchlist);
717 0         0 my @replacementlist = _charlist_tr($replacementlist);
718              
719 0         0 my %tr = ();
720 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
721 0 0       0 if (not exists $tr{$searchlist[$i]}) {
722 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
723 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
724             }
725             elsif ($modifier =~ /d/oxms) {
726 0         0 $tr{$searchlist[$i]} = '';
727             }
728             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
729 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
730             }
731             else {
732 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
733             }
734             }
735             }
736              
737 0         0 my $tr = 0;
738 0         0 my $replaced = '';
739 0 0       0 if ($modifier =~ /c/oxms) {
740 0         0 while (defined(my $char = shift @char)) {
741 0 0       0 if (not exists $tr{$char}) {
742 0 0       0 if (defined $replacementlist[0]) {
743 0         0 $replaced .= $replacementlist[0];
744             }
745 0         0 $tr++;
746 0 0       0 if ($modifier =~ /s/oxms) {
747 0   0     0 while (@char and (not exists $tr{$char[0]})) {
748 0         0 shift @char;
749 0         0 $tr++;
750             }
751             }
752             }
753             else {
754 0         0 $replaced .= $char;
755             }
756             }
757             }
758             else {
759 0         0 while (defined(my $char = shift @char)) {
760 0 0       0 if (exists $tr{$char}) {
761 0         0 $replaced .= $tr{$char};
762 0         0 $tr++;
763 0 0       0 if ($modifier =~ /s/oxms) {
764 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
765 0         0 shift @char;
766 0         0 $tr++;
767             }
768             }
769             }
770             else {
771 0         0 $replaced .= $char;
772             }
773             }
774             }
775              
776 0 0       0 if ($modifier =~ /r/oxms) {
777 0         0 return $replaced;
778             }
779             else {
780 0         0 $_[0] = $replaced;
781 0 0       0 if ($bind_operator =~ / !~ /oxms) {
782 0         0 return not $tr;
783             }
784             else {
785 0         0 return $tr;
786             }
787             }
788             }
789              
790             #
791             # Latin-7 chop
792             #
793             sub Char::Elatin7::chop(@) {
794              
795 0     0 0 0 my $chop;
796 0 0       0 if (@_ == 0) {
797 0         0 my @char = /\G ($q_char) /oxmsg;
798 0         0 $chop = pop @char;
799 0         0 $_ = join '', @char;
800             }
801             else {
802 0         0 for (@_) {
803 0         0 my @char = /\G ($q_char) /oxmsg;
804 0         0 $chop = pop @char;
805 0         0 $_ = join '', @char;
806             }
807             }
808 0         0 return $chop;
809             }
810              
811             #
812             # Latin-7 index by octet
813             #
814             sub Char::Elatin7::index($$;$) {
815              
816 0     0 1 0 my($str,$substr,$position) = @_;
817 0   0     0 $position ||= 0;
818 0         0 my $pos = 0;
819              
820 0         0 while ($pos < CORE::length($str)) {
821 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
822 0 0       0 if ($pos >= $position) {
823 0         0 return $pos;
824             }
825             }
826 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
827 0         0 $pos += CORE::length($1);
828             }
829             else {
830 0         0 $pos += 1;
831             }
832             }
833 0         0 return -1;
834             }
835              
836             #
837             # Latin-7 reverse index
838             #
839             sub Char::Elatin7::rindex($$;$) {
840              
841 0     0 0 0 my($str,$substr,$position) = @_;
842 0   0     0 $position ||= CORE::length($str) - 1;
843 0         0 my $pos = 0;
844 0         0 my $rindex = -1;
845              
846 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
847 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
848 0         0 $rindex = $pos;
849             }
850 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
851 0         0 $pos += CORE::length($1);
852             }
853             else {
854 0         0 $pos += 1;
855             }
856             }
857 0         0 return $rindex;
858             }
859              
860             #
861             # Latin-7 lower case first with parameter
862             #
863             sub Char::Elatin7::lcfirst(@) {
864 0 0   0 0 0 if (@_) {
865 0         0 my $s = shift @_;
866 0 0 0     0 if (@_ and wantarray) {
867 0         0 return Char::Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
868             }
869             else {
870 0         0 return Char::Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
871             }
872             }
873             else {
874 0         0 return Char::Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
875             }
876             }
877              
878             #
879             # Latin-7 lower case first without parameter
880             #
881             sub Char::Elatin7::lcfirst_() {
882 0     0 0 0 return Char::Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
883             }
884              
885             #
886             # Latin-7 lower case with parameter
887             #
888             sub Char::Elatin7::lc(@) {
889 0 0   0 0 0 if (@_) {
890 0         0 my $s = shift @_;
891 0 0 0     0 if (@_ and wantarray) {
892 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
893             }
894             else {
895 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
896             }
897             }
898             else {
899 0         0 return Char::Elatin7::lc_();
900             }
901             }
902              
903             #
904             # Latin-7 lower case without parameter
905             #
906             sub Char::Elatin7::lc_() {
907 0     0 0 0 my $s = $_;
908 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
909             }
910              
911             #
912             # Latin-7 upper case first with parameter
913             #
914             sub Char::Elatin7::ucfirst(@) {
915 0 0   0 0 0 if (@_) {
916 0         0 my $s = shift @_;
917 0 0 0     0 if (@_ and wantarray) {
918 0         0 return Char::Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
919             }
920             else {
921 0         0 return Char::Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
922             }
923             }
924             else {
925 0         0 return Char::Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
926             }
927             }
928              
929             #
930             # Latin-7 upper case first without parameter
931             #
932             sub Char::Elatin7::ucfirst_() {
933 0     0 0 0 return Char::Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
934             }
935              
936             #
937             # Latin-7 upper case with parameter
938             #
939             sub Char::Elatin7::uc(@) {
940 0 0   0 0 0 if (@_) {
941 0         0 my $s = shift @_;
942 0 0 0     0 if (@_ and wantarray) {
943 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
944             }
945             else {
946 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
947             }
948             }
949             else {
950 0         0 return Char::Elatin7::uc_();
951             }
952             }
953              
954             #
955             # Latin-7 upper case without parameter
956             #
957             sub Char::Elatin7::uc_() {
958 0     0 0 0 my $s = $_;
959 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
960             }
961              
962             #
963             # Latin-7 fold case with parameter
964             #
965             sub Char::Elatin7::fc(@) {
966 0 0   0 0 0 if (@_) {
967 0         0 my $s = shift @_;
968 0 0 0     0 if (@_ and wantarray) {
969 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
970             }
971             else {
972 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
973             }
974             }
975             else {
976 0         0 return Char::Elatin7::fc_();
977             }
978             }
979              
980             #
981             # Latin-7 fold case without parameter
982             #
983             sub Char::Elatin7::fc_() {
984 0     0 0 0 my $s = $_;
985 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
986             }
987              
988             #
989             # Latin-7 regexp capture
990             #
991             {
992             sub Char::Elatin7::capture {
993 0     0 1 0 return $_[0];
994             }
995             }
996              
997             #
998             # Latin-7 regexp ignore case modifier
999             #
1000             sub Char::Elatin7::ignorecase {
1001              
1002 0     0 0 0 my @string = @_;
1003 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1004              
1005             # ignore case of $scalar or @array
1006 0         0 for my $string (@string) {
1007              
1008             # split regexp
1009 0         0 my @char = $string =~ /\G(
1010             \[\^ |
1011             \\? (?:$q_char)
1012             )/oxmsg;
1013              
1014             # unescape character
1015 0         0 for (my $i=0; $i <= $#char; $i++) {
1016 0 0       0 next if not defined $char[$i];
1017              
1018             # open character class [...]
1019 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1020 0         0 my $left = $i;
1021              
1022             # [] make die "unmatched [] in regexp ..."
1023              
1024 0 0       0 if ($char[$i+1] eq ']') {
1025 0         0 $i++;
1026             }
1027              
1028 0         0 while (1) {
1029 0 0       0 if (++$i > $#char) {
1030 0         0 croak "Unmatched [] in regexp";
1031             }
1032 0 0       0 if ($char[$i] eq ']') {
1033 0         0 my $right = $i;
1034 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1035              
1036             # escape character
1037 0         0 for my $char (@charlist) {
1038 0 0       0 if (0) {
1039             }
1040              
1041 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1042 0         0 $char = $1 . '\\' . $char;
1043             }
1044             }
1045              
1046             # [...]
1047 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1048              
1049 0         0 $i = $left;
1050 0         0 last;
1051             }
1052             }
1053             }
1054              
1055             # open character class [^...]
1056             elsif ($char[$i] eq '[^') {
1057 0         0 my $left = $i;
1058              
1059             # [^] make die "unmatched [] in regexp ..."
1060              
1061 0 0       0 if ($char[$i+1] eq ']') {
1062 0         0 $i++;
1063             }
1064              
1065 0         0 while (1) {
1066 0 0       0 if (++$i > $#char) {
1067 0         0 croak "Unmatched [] in regexp";
1068             }
1069 0 0       0 if ($char[$i] eq ']') {
1070 0         0 my $right = $i;
1071 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1072              
1073             # escape character
1074 0         0 for my $char (@charlist) {
1075 0 0       0 if (0) {
1076             }
1077              
1078 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1079 0         0 $char = '\\' . $char;
1080             }
1081             }
1082              
1083             # [^...]
1084 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1085              
1086 0         0 $i = $left;
1087 0         0 last;
1088             }
1089             }
1090             }
1091              
1092             # rewrite classic character class or escape character
1093             elsif (my $char = classic_character_class($char[$i])) {
1094 0         0 $char[$i] = $char;
1095             }
1096              
1097             # with /i modifier
1098             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1099 0         0 my $uc = Char::Elatin7::uc($char[$i]);
1100 0         0 my $fc = Char::Elatin7::fc($char[$i]);
1101 0 0       0 if ($uc ne $fc) {
1102 0 0       0 if (CORE::length($fc) == 1) {
1103 0         0 $char[$i] = '[' . $uc . $fc . ']';
1104             }
1105             else {
1106 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1107             }
1108             }
1109             }
1110             }
1111              
1112             # characterize
1113 0         0 for (my $i=0; $i <= $#char; $i++) {
1114 0 0       0 next if not defined $char[$i];
1115              
1116 0 0       0 if (0) {
1117             }
1118              
1119             # quote character before ? + * {
1120 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1121 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1122 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1123             }
1124             }
1125             }
1126              
1127 0         0 $string = join '', @char;
1128             }
1129              
1130             # make regexp string
1131 0         0 return @string;
1132             }
1133              
1134             #
1135             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1136             #
1137             sub Char::Elatin7::classic_character_class {
1138 0     0 0 0 my($char) = @_;
1139              
1140             return {
1141 0   0     0 '\D' => '${Char::Elatin7::eD}',
1142             '\S' => '${Char::Elatin7::eS}',
1143             '\W' => '${Char::Elatin7::eW}',
1144             '\d' => '[0-9]',
1145              
1146             # Before Perl 5.6, \s only matched the five whitespace characters
1147             # tab, newline, form-feed, carriage return, and the space character
1148             # itself, which, taken together, is the character class [\t\n\f\r ].
1149              
1150             # Vertical tabs are now whitespace
1151             # \s in a regex now matches a vertical tab in all circumstances.
1152             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1153             # \t \n \v \f \r space
1154             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1155             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1156             '\s' => '\s',
1157              
1158             '\w' => '[0-9A-Z_a-z]',
1159             '\C' => '[\x00-\xFF]',
1160             '\X' => 'X',
1161              
1162             # \h \v \H \V
1163              
1164             # P.114 Character Class Shortcuts
1165             # in Chapter 7: In the World of Regular Expressions
1166             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1167              
1168             # P.357 13.2.3 Whitespace
1169             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1170             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1171             #
1172             # 0x00009 CHARACTER TABULATION h s
1173             # 0x0000a LINE FEED (LF) vs
1174             # 0x0000b LINE TABULATION v
1175             # 0x0000c FORM FEED (FF) vs
1176             # 0x0000d CARRIAGE RETURN (CR) vs
1177             # 0x00020 SPACE h s
1178              
1179             # P.196 Table 5-9. Alphanumeric regex metasymbols
1180             # in Chapter 5. Pattern Matching
1181             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1182              
1183             # (and so on)
1184              
1185             '\H' => '${Char::Elatin7::eH}',
1186             '\V' => '${Char::Elatin7::eV}',
1187             '\h' => '[\x09\x20]',
1188             '\v' => '[\x0A\x0B\x0C\x0D]',
1189             '\R' => '${Char::Elatin7::eR}',
1190              
1191             # \N
1192             #
1193             # http://perldoc.perl.org/perlre.html
1194             # Character Classes and other Special Escapes
1195             # Any character but \n (experimental). Not affected by /s modifier
1196              
1197             '\N' => '${Char::Elatin7::eN}',
1198              
1199             # \b \B
1200              
1201             # P.180 Boundaries: The \b and \B Assertions
1202             # in Chapter 5: Pattern Matching
1203             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1204              
1205             # P.219 Boundaries: The \b and \B Assertions
1206             # in Chapter 5: Pattern Matching
1207             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1208              
1209             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1210             '\b' => '${Char::Elatin7::eb}',
1211              
1212             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1213             '\B' => '${Char::Elatin7::eB}',
1214              
1215             }->{$char} || '';
1216             }
1217              
1218             #
1219             # prepare Latin-7 characters per length
1220             #
1221              
1222             # 1 octet characters
1223             my @chars1 = ();
1224             sub chars1 {
1225 0 0   0 0 0 if (@chars1) {
1226 0         0 return @chars1;
1227             }
1228 0 0       0 if (exists $range_tr{1}) {
1229 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1230 0         0 while (my @range = splice(@ranges,0,1)) {
1231 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1232 0         0 push @chars1, pack 'C', $oct0;
1233             }
1234             }
1235             }
1236 0         0 return @chars1;
1237             }
1238              
1239             # 2 octets characters
1240             my @chars2 = ();
1241             sub chars2 {
1242 0 0   0 0 0 if (@chars2) {
1243 0         0 return @chars2;
1244             }
1245 0 0       0 if (exists $range_tr{2}) {
1246 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1247 0         0 while (my @range = splice(@ranges,0,2)) {
1248 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1249 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1250 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1251             }
1252             }
1253             }
1254             }
1255 0         0 return @chars2;
1256             }
1257              
1258             # 3 octets characters
1259             my @chars3 = ();
1260             sub chars3 {
1261 0 0   0 0 0 if (@chars3) {
1262 0         0 return @chars3;
1263             }
1264 0 0       0 if (exists $range_tr{3}) {
1265 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1266 0         0 while (my @range = splice(@ranges,0,3)) {
1267 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1268 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1269 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1270 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1271             }
1272             }
1273             }
1274             }
1275             }
1276 0         0 return @chars3;
1277             }
1278              
1279             # 4 octets characters
1280             my @chars4 = ();
1281             sub chars4 {
1282 0 0   0 0 0 if (@chars4) {
1283 0         0 return @chars4;
1284             }
1285 0 0       0 if (exists $range_tr{4}) {
1286 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1287 0         0 while (my @range = splice(@ranges,0,4)) {
1288 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1289 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1290 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1291 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1292 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1293             }
1294             }
1295             }
1296             }
1297             }
1298             }
1299 0         0 return @chars4;
1300             }
1301              
1302             #
1303             # Latin-7 open character list for tr
1304             #
1305             sub _charlist_tr {
1306              
1307 0     0   0 local $_ = shift @_;
1308              
1309             # unescape character
1310 0         0 my @char = ();
1311 0         0 while (not /\G \z/oxmsgc) {
1312 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1313 0         0 push @char, '\-';
1314             }
1315             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1316 0         0 push @char, CORE::chr(oct $1);
1317             }
1318             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1319 0         0 push @char, CORE::chr(hex $1);
1320             }
1321             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1322 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1323             }
1324             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1325 0         0 push @char, {
1326             '\0' => "\0",
1327             '\n' => "\n",
1328             '\r' => "\r",
1329             '\t' => "\t",
1330             '\f' => "\f",
1331             '\b' => "\x08", # \b means backspace in character class
1332             '\a' => "\a",
1333             '\e' => "\e",
1334             }->{$1};
1335             }
1336             elsif (/\G \\ ($q_char) /oxmsgc) {
1337 0         0 push @char, $1;
1338             }
1339             elsif (/\G ($q_char) /oxmsgc) {
1340 0         0 push @char, $1;
1341             }
1342             }
1343              
1344             # join separated multiple-octet
1345 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1346              
1347             # unescape '-'
1348 0         0 my @i = ();
1349 0         0 for my $i (0 .. $#char) {
1350 0 0       0 if ($char[$i] eq '\-') {
    0          
1351 0         0 $char[$i] = '-';
1352             }
1353             elsif ($char[$i] eq '-') {
1354 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1355 0         0 push @i, $i;
1356             }
1357             }
1358             }
1359              
1360             # open character list (reverse for splice)
1361 0         0 for my $i (CORE::reverse @i) {
1362 0         0 my @range = ();
1363              
1364             # range error
1365 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1366 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1367             }
1368              
1369             # range of multiple-octet code
1370 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1371 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1372 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1373             }
1374             elsif (CORE::length($char[$i+1]) == 2) {
1375 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1376 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1377             }
1378             elsif (CORE::length($char[$i+1]) == 3) {
1379 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1380 0         0 push @range, chars2();
1381 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1382             }
1383             elsif (CORE::length($char[$i+1]) == 4) {
1384 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1385 0         0 push @range, chars2();
1386 0         0 push @range, chars3();
1387 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1388             }
1389             else {
1390 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1391             }
1392             }
1393             elsif (CORE::length($char[$i-1]) == 2) {
1394 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1395 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1396             }
1397             elsif (CORE::length($char[$i+1]) == 3) {
1398 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
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 $_} chars2();
  0         0  
1403 0         0 push @range, chars3();
1404 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1405             }
1406             else {
1407 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1408             }
1409             }
1410             elsif (CORE::length($char[$i-1]) == 3) {
1411 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1412 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1413             }
1414             elsif (CORE::length($char[$i+1]) == 4) {
1415 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1416 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1417             }
1418             else {
1419 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1420             }
1421             }
1422             elsif (CORE::length($char[$i-1]) == 4) {
1423 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1424 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1425             }
1426             else {
1427 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1428             }
1429             }
1430             else {
1431 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1432             }
1433              
1434 0         0 splice @char, $i-1, 3, @range;
1435             }
1436              
1437 0         0 return @char;
1438             }
1439              
1440             #
1441             # Latin-7 open character class
1442             #
1443             sub _cc {
1444 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1445 0         0 die __FILE__, ": subroutine cc got no parameter.";
1446             }
1447             elsif (scalar(@_) == 1) {
1448 0         0 return sprintf('\x%02X',$_[0]);
1449             }
1450             elsif (scalar(@_) == 2) {
1451 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1452 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1453             }
1454             elsif ($_[0] == $_[1]) {
1455 0         0 return sprintf('\x%02X',$_[0]);
1456             }
1457             elsif (($_[0]+1) == $_[1]) {
1458 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1459             }
1460             else {
1461 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1462             }
1463             }
1464             else {
1465 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1466             }
1467             }
1468              
1469             #
1470             # Latin-7 octet range
1471             #
1472             sub _octets {
1473 0     0   0 my $length = shift @_;
1474              
1475 0 0       0 if ($length == 1) {
1476 0         0 my($a1) = unpack 'C', $_[0];
1477 0         0 my($z1) = unpack 'C', $_[1];
1478              
1479 0 0       0 if ($a1 > $z1) {
1480 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1481             }
1482              
1483 0 0       0 if ($a1 == $z1) {
    0          
1484 0         0 return sprintf('\x%02X',$a1);
1485             }
1486             elsif (($a1+1) == $z1) {
1487 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1488             }
1489             else {
1490 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1491             }
1492             }
1493             else {
1494 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1495             }
1496             }
1497              
1498             #
1499             # Latin-7 range regexp
1500             #
1501             sub _range_regexp {
1502 0     0   0 my($length,$first,$last) = @_;
1503              
1504 0         0 my @range_regexp = ();
1505 0 0       0 if (not exists $range_tr{$length}) {
1506 0         0 return @range_regexp;
1507             }
1508              
1509 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1510 0         0 while (my @range = splice(@ranges,0,$length)) {
1511 0         0 my $min = '';
1512 0         0 my $max = '';
1513 0         0 for (my $i=0; $i < $length; $i++) {
1514 0         0 $min .= pack 'C', $range[$i][0];
1515 0         0 $max .= pack 'C', $range[$i][-1];
1516             }
1517              
1518             # min___max
1519             # FIRST_____________LAST
1520             # (nothing)
1521              
1522 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1523             }
1524              
1525             # **********
1526             # min_________max
1527             # FIRST_____________LAST
1528             # **********
1529              
1530             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1531 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1532             }
1533              
1534             # **********************
1535             # min________________max
1536             # FIRST_____________LAST
1537             # **********************
1538              
1539             elsif (($min eq $first) and ($max eq $last)) {
1540 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1541             }
1542              
1543             # *********
1544             # min___max
1545             # FIRST_____________LAST
1546             # *********
1547              
1548             elsif (($first le $min) and ($max le $last)) {
1549 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1550             }
1551              
1552             # **********************
1553             # min__________________________max
1554             # FIRST_____________LAST
1555             # **********************
1556              
1557             elsif (($min le $first) and ($last le $max)) {
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 ($min le $last) and ($last le $max)) {
1567 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1568             }
1569              
1570             # min___max
1571             # FIRST_____________LAST
1572             # (nothing)
1573              
1574             elsif ($last lt $min) {
1575             }
1576              
1577             else {
1578 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1579             }
1580             }
1581              
1582 0         0 return @range_regexp;
1583             }
1584              
1585             #
1586             # Latin-7 open character list for qr and not qr
1587             #
1588             sub _charlist {
1589              
1590 0     0   0 my $modifier = pop @_;
1591 0         0 my @char = @_;
1592              
1593 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1594              
1595             # unescape character
1596 0         0 for (my $i=0; $i <= $#char; $i++) {
1597              
1598             # escape - to ...
1599 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1600 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1601 0         0 $char[$i] = '...';
1602             }
1603             }
1604              
1605             # octal escape sequence
1606             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1607 0         0 $char[$i] = octchr($1);
1608             }
1609              
1610             # hexadecimal escape sequence
1611             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1612 0         0 $char[$i] = hexchr($1);
1613             }
1614              
1615             # \N{CHARNAME} --> N\{CHARNAME}
1616             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1617 0         0 $char[$i] = $1 . '\\' . $2;
1618             }
1619              
1620             # \p{PROPERTY} --> p\{PROPERTY}
1621             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1622 0         0 $char[$i] = $1 . '\\' . $2;
1623             }
1624              
1625             # \P{PROPERTY} --> P\{PROPERTY}
1626             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1627 0         0 $char[$i] = $1 . '\\' . $2;
1628             }
1629              
1630             # \p, \P, \X --> p, P, X
1631             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1632 0         0 $char[$i] = $1;
1633             }
1634              
1635             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1636 0         0 $char[$i] = CORE::chr oct $1;
1637             }
1638             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1639 0         0 $char[$i] = CORE::chr hex $1;
1640             }
1641             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1642 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1643             }
1644             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1645 0         0 $char[$i] = {
1646             '\0' => "\0",
1647             '\n' => "\n",
1648             '\r' => "\r",
1649             '\t' => "\t",
1650             '\f' => "\f",
1651             '\b' => "\x08", # \b means backspace in character class
1652             '\a' => "\a",
1653             '\e' => "\e",
1654             '\d' => '[0-9]',
1655              
1656             # Vertical tabs are now whitespace
1657             # \s in a regex now matches a vertical tab in all circumstances.
1658             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1659             # \t \n \v \f \r space
1660             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1661             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1662             '\s' => '\s',
1663              
1664             '\w' => '[0-9A-Z_a-z]',
1665             '\D' => '${Char::Elatin7::eD}',
1666             '\S' => '${Char::Elatin7::eS}',
1667             '\W' => '${Char::Elatin7::eW}',
1668              
1669             '\H' => '${Char::Elatin7::eH}',
1670             '\V' => '${Char::Elatin7::eV}',
1671             '\h' => '[\x09\x20]',
1672             '\v' => '[\x0A\x0B\x0C\x0D]',
1673             '\R' => '${Char::Elatin7::eR}',
1674              
1675             }->{$1};
1676             }
1677              
1678             # POSIX-style character classes
1679             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1680 0         0 $char[$i] = {
1681              
1682             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1683             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1684             '[:^lower:]' => '${Char::Elatin7::not_lower_i}',
1685             '[:^upper:]' => '${Char::Elatin7::not_upper_i}',
1686              
1687             }->{$1};
1688             }
1689             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1690 0         0 $char[$i] = {
1691              
1692             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1693             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1694             '[:ascii:]' => '[\x00-\x7F]',
1695             '[:blank:]' => '[\x09\x20]',
1696             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1697             '[:digit:]' => '[\x30-\x39]',
1698             '[:graph:]' => '[\x21-\x7F]',
1699             '[:lower:]' => '[\x61-\x7A]',
1700             '[:print:]' => '[\x20-\x7F]',
1701             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1702              
1703             # P.174 POSIX-Style Character Classes
1704             # in Chapter 5: Pattern Matching
1705             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1706              
1707             # P.311 11.2.4 Character Classes and other Special Escapes
1708             # in Chapter 11: perlre: Perl regular expressions
1709             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1710              
1711             # P.210 POSIX-Style Character Classes
1712             # in Chapter 5: Pattern Matching
1713             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1714              
1715             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1716              
1717             '[:upper:]' => '[\x41-\x5A]',
1718             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1719             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1720             '[:^alnum:]' => '${Char::Elatin7::not_alnum}',
1721             '[:^alpha:]' => '${Char::Elatin7::not_alpha}',
1722             '[:^ascii:]' => '${Char::Elatin7::not_ascii}',
1723             '[:^blank:]' => '${Char::Elatin7::not_blank}',
1724             '[:^cntrl:]' => '${Char::Elatin7::not_cntrl}',
1725             '[:^digit:]' => '${Char::Elatin7::not_digit}',
1726             '[:^graph:]' => '${Char::Elatin7::not_graph}',
1727             '[:^lower:]' => '${Char::Elatin7::not_lower}',
1728             '[:^print:]' => '${Char::Elatin7::not_print}',
1729             '[:^punct:]' => '${Char::Elatin7::not_punct}',
1730             '[:^space:]' => '${Char::Elatin7::not_space}',
1731             '[:^upper:]' => '${Char::Elatin7::not_upper}',
1732             '[:^word:]' => '${Char::Elatin7::not_word}',
1733             '[:^xdigit:]' => '${Char::Elatin7::not_xdigit}',
1734              
1735             }->{$1};
1736             }
1737             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1738 0         0 $char[$i] = $1;
1739             }
1740             }
1741              
1742             # open character list
1743 0         0 my @singleoctet = ();
1744 0         0 my @multipleoctet = ();
1745 0         0 for (my $i=0; $i <= $#char; ) {
1746              
1747             # escaped -
1748 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1749 0         0 $i += 1;
1750 0         0 next;
1751             }
1752              
1753             # make range regexp
1754             elsif ($char[$i] eq '...') {
1755              
1756             # range error
1757 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1758 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1759             }
1760             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1761 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1762 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]);
1763             }
1764             }
1765              
1766             # make range regexp per length
1767 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1768 0         0 my @regexp = ();
1769              
1770             # is first and last
1771 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1772 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1773             }
1774              
1775             # is first
1776             elsif ($length == CORE::length($char[$i-1])) {
1777 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1778             }
1779              
1780             # is inside in first and last
1781             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1782 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1783             }
1784              
1785             # is last
1786             elsif ($length == CORE::length($char[$i+1])) {
1787 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1788             }
1789              
1790             else {
1791 0         0 die __FILE__, ": subroutine make_regexp panic.";
1792             }
1793              
1794 0 0       0 if ($length == 1) {
1795 0         0 push @singleoctet, @regexp;
1796             }
1797             else {
1798 0         0 push @multipleoctet, @regexp;
1799             }
1800             }
1801              
1802 0         0 $i += 2;
1803             }
1804              
1805             # with /i modifier
1806             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1807 0 0       0 if ($modifier =~ /i/oxms) {
1808 0         0 my $uc = Char::Elatin7::uc($char[$i]);
1809 0         0 my $fc = Char::Elatin7::fc($char[$i]);
1810 0 0       0 if ($uc ne $fc) {
1811 0 0       0 if (CORE::length($fc) == 1) {
1812 0         0 push @singleoctet, $uc, $fc;
1813             }
1814             else {
1815 0         0 push @singleoctet, $uc;
1816 0         0 push @multipleoctet, $fc;
1817             }
1818             }
1819             else {
1820 0         0 push @singleoctet, $char[$i];
1821             }
1822             }
1823             else {
1824 0         0 push @singleoctet, $char[$i];
1825             }
1826 0         0 $i += 1;
1827             }
1828              
1829             # single character of single octet code
1830             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1831 0         0 push @singleoctet, "\t", "\x20";
1832 0         0 $i += 1;
1833             }
1834             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1835 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1836 0         0 $i += 1;
1837             }
1838             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1839 0         0 push @singleoctet, $char[$i];
1840 0         0 $i += 1;
1841             }
1842              
1843             # single character of multiple-octet code
1844             else {
1845 0         0 push @multipleoctet, $char[$i];
1846 0         0 $i += 1;
1847             }
1848             }
1849              
1850             # quote metachar
1851 0         0 for (@singleoctet) {
1852 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1853 0         0 $_ = '-';
1854             }
1855             elsif (/\A \n \z/oxms) {
1856 0         0 $_ = '\n';
1857             }
1858             elsif (/\A \r \z/oxms) {
1859 0         0 $_ = '\r';
1860             }
1861             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1862 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1863             }
1864             elsif (/\A [\x00-\xFF] \z/oxms) {
1865 0         0 $_ = quotemeta $_;
1866             }
1867             }
1868              
1869             # return character list
1870 0         0 return \@singleoctet, \@multipleoctet;
1871             }
1872              
1873             #
1874             # Latin-7 octal escape sequence
1875             #
1876             sub octchr {
1877 0     0 0 0 my($octdigit) = @_;
1878              
1879 0         0 my @binary = ();
1880 0         0 for my $octal (split(//,$octdigit)) {
1881 0         0 push @binary, {
1882             '0' => '000',
1883             '1' => '001',
1884             '2' => '010',
1885             '3' => '011',
1886             '4' => '100',
1887             '5' => '101',
1888             '6' => '110',
1889             '7' => '111',
1890             }->{$octal};
1891             }
1892 0         0 my $binary = join '', @binary;
1893              
1894 0         0 my $octchr = {
1895             # 1234567
1896             1 => pack('B*', "0000000$binary"),
1897             2 => pack('B*', "000000$binary"),
1898             3 => pack('B*', "00000$binary"),
1899             4 => pack('B*', "0000$binary"),
1900             5 => pack('B*', "000$binary"),
1901             6 => pack('B*', "00$binary"),
1902             7 => pack('B*', "0$binary"),
1903             0 => pack('B*', "$binary"),
1904              
1905             }->{CORE::length($binary) % 8};
1906              
1907 0         0 return $octchr;
1908             }
1909              
1910             #
1911             # Latin-7 hexadecimal escape sequence
1912             #
1913             sub hexchr {
1914 0     0 0 0 my($hexdigit) = @_;
1915              
1916 0         0 my $hexchr = {
1917             1 => pack('H*', "0$hexdigit"),
1918             0 => pack('H*', "$hexdigit"),
1919              
1920             }->{CORE::length($_[0]) % 2};
1921              
1922 0         0 return $hexchr;
1923             }
1924              
1925             #
1926             # Latin-7 open character list for qr
1927             #
1928             sub charlist_qr {
1929              
1930 0     0 0 0 my $modifier = pop @_;
1931 0         0 my @char = @_;
1932              
1933 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1934 0         0 my @singleoctet = @$singleoctet;
1935 0         0 my @multipleoctet = @$multipleoctet;
1936              
1937             # return character list
1938 0 0       0 if (scalar(@singleoctet) >= 1) {
1939              
1940             # with /i modifier
1941 0 0       0 if ($modifier =~ m/i/oxms) {
1942 0         0 my %singleoctet_ignorecase = ();
1943 0         0 for (@singleoctet) {
1944 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1945 0         0 for my $ord (hex($1) .. hex($2)) {
1946 0         0 my $char = CORE::chr($ord);
1947 0         0 my $uc = Char::Elatin7::uc($char);
1948 0         0 my $fc = Char::Elatin7::fc($char);
1949 0 0       0 if ($uc eq $fc) {
1950 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1951             }
1952             else {
1953 0 0       0 if (CORE::length($fc) == 1) {
1954 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1955 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1956             }
1957             else {
1958 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1959 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1960             }
1961             }
1962             }
1963             }
1964 0 0       0 if ($_ ne '') {
1965 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1966             }
1967             }
1968 0         0 my $i = 0;
1969 0         0 my @singleoctet_ignorecase = ();
1970 0         0 for my $ord (0 .. 255) {
1971 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1972 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1973             }
1974             else {
1975 0         0 $i++;
1976             }
1977             }
1978 0         0 @singleoctet = ();
1979 0         0 for my $range (@singleoctet_ignorecase) {
1980 0 0       0 if (ref $range) {
1981 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1982 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1983             }
1984             elsif (scalar(@{$range}) == 2) {
1985 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1986             }
1987             else {
1988 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1989             }
1990             }
1991             }
1992             }
1993              
1994 0         0 my $not_anchor = '';
1995              
1996 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1997             }
1998 0 0       0 if (scalar(@multipleoctet) >= 2) {
1999 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2000             }
2001             else {
2002 0         0 return $multipleoctet[0];
2003             }
2004             }
2005              
2006             #
2007             # Latin-7 open character list for not qr
2008             #
2009             sub charlist_not_qr {
2010              
2011 0     0 0 0 my $modifier = pop @_;
2012 0         0 my @char = @_;
2013              
2014 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2015 0         0 my @singleoctet = @$singleoctet;
2016 0         0 my @multipleoctet = @$multipleoctet;
2017              
2018             # with /i modifier
2019 0 0       0 if ($modifier =~ m/i/oxms) {
2020 0         0 my %singleoctet_ignorecase = ();
2021 0         0 for (@singleoctet) {
2022 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2023 0         0 for my $ord (hex($1) .. hex($2)) {
2024 0         0 my $char = CORE::chr($ord);
2025 0         0 my $uc = Char::Elatin7::uc($char);
2026 0         0 my $fc = Char::Elatin7::fc($char);
2027 0 0       0 if ($uc eq $fc) {
2028 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2029             }
2030             else {
2031 0 0       0 if (CORE::length($fc) == 1) {
2032 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2033 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2034             }
2035             else {
2036 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2037 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2038             }
2039             }
2040             }
2041             }
2042 0 0       0 if ($_ ne '') {
2043 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2044             }
2045             }
2046 0         0 my $i = 0;
2047 0         0 my @singleoctet_ignorecase = ();
2048 0         0 for my $ord (0 .. 255) {
2049 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2050 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2051             }
2052             else {
2053 0         0 $i++;
2054             }
2055             }
2056 0         0 @singleoctet = ();
2057 0         0 for my $range (@singleoctet_ignorecase) {
2058 0 0       0 if (ref $range) {
2059 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2060 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2061             }
2062             elsif (scalar(@{$range}) == 2) {
2063 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2064             }
2065             else {
2066 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2067             }
2068             }
2069             }
2070             }
2071              
2072             # return character list
2073 0 0       0 if (scalar(@multipleoctet) >= 1) {
2074 0 0       0 if (scalar(@singleoctet) >= 1) {
2075              
2076             # any character other than multiple-octet and single octet character class
2077 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2078             }
2079             else {
2080              
2081             # any character other than multiple-octet character class
2082 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2083             }
2084             }
2085             else {
2086 0 0       0 if (scalar(@singleoctet) >= 1) {
2087              
2088             # any character other than single octet character class
2089 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2090             }
2091             else {
2092              
2093             # any character
2094 0         0 return "(?:$your_char)";
2095             }
2096             }
2097             }
2098              
2099             #
2100             # open file in read mode
2101             #
2102             sub _open_r {
2103 197     197   670 my(undef,$file) = @_;
2104 197         828 $file =~ s#\A (\s) #./$1#oxms;
2105 197   33     26513 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2106             open($_[0],"< $file\0");
2107             }
2108              
2109             #
2110             # open file in write mode
2111             #
2112             sub _open_w {
2113 0     0   0 my(undef,$file) = @_;
2114 0         0 $file =~ s#\A (\s) #./$1#oxms;
2115 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2116             open($_[0],"> $file\0");
2117             }
2118              
2119             #
2120             # open file in append mode
2121             #
2122             sub _open_a {
2123 0     0   0 my(undef,$file) = @_;
2124 0         0 $file =~ s#\A (\s) #./$1#oxms;
2125 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2126             open($_[0],">> $file\0");
2127             }
2128              
2129             #
2130             # safe system
2131             #
2132             sub _systemx {
2133              
2134             # P.707 29.2.33. exec
2135             # in Chapter 29: Functions
2136             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2137             #
2138             # Be aware that in older releases of Perl, exec (and system) did not flush
2139             # your output buffer, so you needed to enable command buffering by setting $|
2140             # on one or more filehandles to avoid lost output in the case of exec, or
2141             # misordererd output in the case of system. This situation was largely remedied
2142             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2143              
2144             # P.855 exec
2145             # in Chapter 27: Functions
2146             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2147             #
2148             # In very old release of Perl (before v5.6), exec (and system) did not flush
2149             # your output buffer, so you needed to enable command buffering by setting $|
2150             # on one or more filehandles to avoid lost output with exec or misordered
2151             # output with system.
2152              
2153 197     197   715 $| = 1;
2154              
2155             # P.565 23.1.2. Cleaning Up Your Environment
2156             # in Chapter 23: Security
2157             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2158              
2159             # P.656 Cleaning Up Your Environment
2160             # in Chapter 20: Security
2161             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2162              
2163             # local $ENV{'PATH'} = '.';
2164 197         1923 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2165              
2166             # P.707 29.2.33. exec
2167             # in Chapter 29: Functions
2168             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2169             #
2170             # As we mentioned earlier, exec treats a discrete list of arguments as an
2171             # indication that it should bypass shell processing. However, there is one
2172             # place where you might still get tripped up. The exec call (and system, too)
2173             # will not distinguish between a single scalar argument and an array containing
2174             # only one element.
2175             #
2176             # @args = ("echo surprise"); # just one element in list
2177             # exec @args # still subject to shell escapes
2178             # or die "exec: $!"; # because @args == 1
2179             #
2180             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2181             # first argument as the pathname, which forces the rest of the arguments to be
2182             # interpreted as a list, even if there is only one of them:
2183             #
2184             # exec { $args[0] } @args # safe even with one-argument list
2185             # or die "can't exec @args: $!";
2186              
2187             # P.855 exec
2188             # in Chapter 27: Functions
2189             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2190             #
2191             # As we mentioned earlier, exec treats a discrete list of arguments as a
2192             # directive to bypass shell processing. However, there is one place where
2193             # you might still get tripped up. The exec call (and system, too) cannot
2194             # distinguish between a single scalar argument and an array containing
2195             # only one element.
2196             #
2197             # @args = ("echo surprise"); # just one element in list
2198             # exec @args # still subject to shell escapes
2199             # || die "exec: $!"; # because @args == 1
2200             #
2201             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2202             # argument as the pathname, which forces the rest of the arguments to be
2203             # interpreted as a list, even if there is only one of them:
2204             #
2205             # exec { $args[0] } @args # safe even with one-argument list
2206             # || die "can't exec @args: $!";
2207              
2208 197         398 return CORE::system { $_[0] } @_; # safe even with one-argument list
  197         23459436  
2209             }
2210              
2211             #
2212             # Latin-7 order to character (with parameter)
2213             #
2214             sub Char::Elatin7::chr(;$) {
2215              
2216 0 0   0 0   my $c = @_ ? $_[0] : $_;
2217              
2218 0 0         if ($c == 0x00) {
2219 0           return "\x00";
2220             }
2221             else {
2222 0           my @chr = ();
2223 0           while ($c > 0) {
2224 0           unshift @chr, ($c % 0x100);
2225 0           $c = int($c / 0x100);
2226             }
2227 0           return pack 'C*', @chr;
2228             }
2229             }
2230              
2231             #
2232             # Latin-7 order to character (without parameter)
2233             #
2234             sub Char::Elatin7::chr_() {
2235              
2236 0     0 0   my $c = $_;
2237              
2238 0 0         if ($c == 0x00) {
2239 0           return "\x00";
2240             }
2241             else {
2242 0           my @chr = ();
2243 0           while ($c > 0) {
2244 0           unshift @chr, ($c % 0x100);
2245 0           $c = int($c / 0x100);
2246             }
2247 0           return pack 'C*', @chr;
2248             }
2249             }
2250              
2251             #
2252             # Latin-7 path globbing (with parameter)
2253             #
2254             sub Char::Elatin7::glob($) {
2255              
2256 0 0   0 0   if (wantarray) {
2257 0           my @glob = _DOS_like_glob(@_);
2258 0           for my $glob (@glob) {
2259 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2260             }
2261 0           return @glob;
2262             }
2263             else {
2264 0           my $glob = _DOS_like_glob(@_);
2265 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2266 0           return $glob;
2267             }
2268             }
2269              
2270             #
2271             # Latin-7 path globbing (without parameter)
2272             #
2273             sub Char::Elatin7::glob_() {
2274              
2275 0 0   0 0   if (wantarray) {
2276 0           my @glob = _DOS_like_glob();
2277 0           for my $glob (@glob) {
2278 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2279             }
2280 0           return @glob;
2281             }
2282             else {
2283 0           my $glob = _DOS_like_glob();
2284 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2285 0           return $glob;
2286             }
2287             }
2288              
2289             #
2290             # Latin-7 path globbing via File::DosGlob 1.10
2291             #
2292             # Often I confuse "_dosglob" and "_doglob".
2293             # So, I renamed "_dosglob" to "_DOS_like_glob".
2294             #
2295             my %iter;
2296             my %entries;
2297             sub _DOS_like_glob {
2298              
2299             # context (keyed by second cxix argument provided by core)
2300 0     0     my($expr,$cxix) = @_;
2301              
2302             # glob without args defaults to $_
2303 0 0         $expr = $_ if not defined $expr;
2304              
2305             # represents the current user's home directory
2306             #
2307             # 7.3. Expanding Tildes in Filenames
2308             # in Chapter 7. File Access
2309             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2310             #
2311             # and File::HomeDir, File::HomeDir::Windows module
2312              
2313             # DOS-like system
2314 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2315 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2316 0           { my_home_MSWin32() }oxmse;
2317             }
2318              
2319             # UNIX-like system
2320             else {
2321 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2322 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2323             }
2324              
2325             # assume global context if not provided one
2326 0 0         $cxix = '_G_' if not defined $cxix;
2327 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2328              
2329             # if we're just beginning, do it all first
2330 0 0         if ($iter{$cxix} == 0) {
2331 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2332             }
2333              
2334             # chuck it all out, quick or slow
2335 0 0         if (wantarray) {
2336 0           delete $iter{$cxix};
2337 0           return @{delete $entries{$cxix}};
  0            
2338             }
2339             else {
2340 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2341 0           return shift @{$entries{$cxix}};
  0            
2342             }
2343             else {
2344             # return undef for EOL
2345 0           delete $iter{$cxix};
2346 0           delete $entries{$cxix};
2347 0           return undef;
2348             }
2349             }
2350             }
2351              
2352             #
2353             # Latin-7 path globbing subroutine
2354             #
2355             sub _do_glob {
2356              
2357 0     0     my($cond,@expr) = @_;
2358 0           my @glob = ();
2359 0           my $fix_drive_relative_paths = 0;
2360              
2361             OUTER:
2362 0           for my $expr (@expr) {
2363 0 0         next OUTER if not defined $expr;
2364 0 0         next OUTER if $expr eq '';
2365              
2366 0           my @matched = ();
2367 0           my @globdir = ();
2368 0           my $head = '.';
2369 0           my $pathsep = '/';
2370 0           my $tail;
2371              
2372             # if argument is within quotes strip em and do no globbing
2373 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2374 0           $expr = $1;
2375 0 0         if ($cond eq 'd') {
2376 0 0         if (-d $expr) {
2377 0           push @glob, $expr;
2378             }
2379             }
2380             else {
2381 0 0         if (-e $expr) {
2382 0           push @glob, $expr;
2383             }
2384             }
2385 0           next OUTER;
2386             }
2387              
2388             # wildcards with a drive prefix such as h:*.pm must be changed
2389             # to h:./*.pm to expand correctly
2390 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2391 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2392 0           $fix_drive_relative_paths = 1;
2393             }
2394             }
2395              
2396 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2397 0 0         if ($tail eq '') {
2398 0           push @glob, $expr;
2399 0           next OUTER;
2400             }
2401 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2402 0 0         if (@globdir = _do_glob('d', $head)) {
2403 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2404 0           next OUTER;
2405             }
2406             }
2407 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2408 0           $head .= $pathsep;
2409             }
2410 0           $expr = $tail;
2411             }
2412              
2413             # If file component has no wildcards, we can avoid opendir
2414 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2415 0 0         if ($head eq '.') {
2416 0           $head = '';
2417             }
2418 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2419 0           $head .= $pathsep;
2420             }
2421 0           $head .= $expr;
2422 0 0         if ($cond eq 'd') {
2423 0 0         if (-d $head) {
2424 0           push @glob, $head;
2425             }
2426             }
2427             else {
2428 0 0         if (-e $head) {
2429 0           push @glob, $head;
2430             }
2431             }
2432 0           next OUTER;
2433             }
2434 0 0         opendir(*DIR, $head) or next OUTER;
2435 0           my @leaf = readdir DIR;
2436 0           closedir DIR;
2437              
2438 0 0         if ($head eq '.') {
2439 0           $head = '';
2440             }
2441 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2442 0           $head .= $pathsep;
2443             }
2444              
2445 0           my $pattern = '';
2446 0           while ($expr =~ / \G ($q_char) /oxgc) {
2447 0           my $char = $1;
2448              
2449             # 6.9. Matching Shell Globs as Regular Expressions
2450             # in Chapter 6. Pattern Matching
2451             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2452             # (and so on)
2453              
2454 0 0         if ($char eq '*') {
    0          
    0          
2455 0           $pattern .= "(?:$your_char)*",
2456             }
2457             elsif ($char eq '?') {
2458 0           $pattern .= "(?:$your_char)?", # DOS style
2459             # $pattern .= "(?:$your_char)", # UNIX style
2460             }
2461             elsif ((my $fc = Char::Elatin7::fc($char)) ne $char) {
2462 0           $pattern .= $fc;
2463             }
2464             else {
2465 0           $pattern .= quotemeta $char;
2466             }
2467             }
2468 0     0     my $matchsub = sub { Char::Elatin7::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2469              
2470             # if ($@) {
2471             # print STDERR "$0: $@\n";
2472             # next OUTER;
2473             # }
2474              
2475             INNER:
2476 0           for my $leaf (@leaf) {
2477 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2478 0           next INNER;
2479             }
2480 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2481 0           next INNER;
2482             }
2483              
2484 0 0         if (&$matchsub($leaf)) {
2485 0           push @matched, "$head$leaf";
2486 0           next INNER;
2487             }
2488              
2489             # [DOS compatibility special case]
2490             # Failed, add a trailing dot and try again, but only...
2491              
2492 0 0 0       if (Char::Elatin7::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2493             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2494             Char::Elatin7::index($pattern,'\\.') != -1 # pattern has a dot.
2495             ) {
2496 0 0         if (&$matchsub("$leaf.")) {
2497 0           push @matched, "$head$leaf";
2498 0           next INNER;
2499             }
2500             }
2501             }
2502 0 0         if (@matched) {
2503 0           push @glob, @matched;
2504             }
2505             }
2506 0 0         if ($fix_drive_relative_paths) {
2507 0           for my $glob (@glob) {
2508 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2509             }
2510             }
2511 0           return @glob;
2512             }
2513              
2514             #
2515             # Latin-7 parse line
2516             #
2517             sub _parse_line {
2518              
2519 0     0     my($line) = @_;
2520              
2521 0           $line .= ' ';
2522 0           my @piece = ();
2523 0           while ($line =~ /
2524             " ( (?: [^"] )* ) " \s+ |
2525             ( (?: [^"\s] )* ) \s+
2526             /oxmsg
2527             ) {
2528 0 0         push @piece, defined($1) ? $1 : $2;
2529             }
2530 0           return @piece;
2531             }
2532              
2533             #
2534             # Latin-7 parse path
2535             #
2536             sub _parse_path {
2537              
2538 0     0     my($path,$pathsep) = @_;
2539              
2540 0           $path .= '/';
2541 0           my @subpath = ();
2542 0           while ($path =~ /
2543             ((?: [^\/\\] )+?) [\/\\]
2544             /oxmsg
2545             ) {
2546 0           push @subpath, $1;
2547             }
2548              
2549 0           my $tail = pop @subpath;
2550 0           my $head = join $pathsep, @subpath;
2551 0           return $head, $tail;
2552             }
2553              
2554             #
2555             # via File::HomeDir::Windows 1.00
2556             #
2557             sub my_home_MSWin32 {
2558              
2559             # A lot of unix people and unix-derived tools rely on
2560             # the ability to overload HOME. We will support it too
2561             # so that they can replace raw HOME calls with File::HomeDir.
2562 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2563 0           return $ENV{'HOME'};
2564             }
2565              
2566             # Do we have a user profile?
2567             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2568 0           return $ENV{'USERPROFILE'};
2569             }
2570              
2571             # Some Windows use something like $ENV{'HOME'}
2572             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2573 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2574             }
2575              
2576 0           return undef;
2577             }
2578              
2579             #
2580             # via File::HomeDir::Unix 1.00
2581             #
2582             sub my_home {
2583 0     0 0   my $home;
2584              
2585 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2586 0           $home = $ENV{'HOME'};
2587             }
2588              
2589             # This is from the original code, but I'm guessing
2590             # it means "login directory" and exists on some Unixes.
2591             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2592 0           $home = $ENV{'LOGDIR'};
2593             }
2594              
2595             ### More-desperate methods
2596              
2597             # Light desperation on any (Unixish) platform
2598             else {
2599 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2600             }
2601              
2602             # On Unix in general, a non-existant home means "no home"
2603             # For example, "nobody"-like users might use /nonexistant
2604 0 0 0       if (defined $home and ! -d($home)) {
2605 0           $home = undef;
2606             }
2607 0           return $home;
2608             }
2609              
2610             #
2611             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2612             #
2613             sub Char::Elatin7::PREMATCH {
2614 0     0 0   return $`;
2615             }
2616              
2617             #
2618             # ${^MATCH}, $MATCH, $& the string that matched
2619             #
2620             sub Char::Elatin7::MATCH {
2621 0     0 0   return $&;
2622             }
2623              
2624             #
2625             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2626             #
2627             sub Char::Elatin7::POSTMATCH {
2628 0     0 0   return $';
2629             }
2630              
2631             #
2632             # Latin-7 character to order (with parameter)
2633             #
2634             sub Char::Latin7::ord(;$) {
2635              
2636 0 0   0 1   local $_ = shift if @_;
2637              
2638 0 0         if (/\A ($q_char) /oxms) {
2639 0           my @ord = unpack 'C*', $1;
2640 0           my $ord = 0;
2641 0           while (my $o = shift @ord) {
2642 0           $ord = $ord * 0x100 + $o;
2643             }
2644 0           return $ord;
2645             }
2646             else {
2647 0           return CORE::ord $_;
2648             }
2649             }
2650              
2651             #
2652             # Latin-7 character to order (without parameter)
2653             #
2654             sub Char::Latin7::ord_() {
2655              
2656 0 0   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-7 reverse
2671             #
2672             sub Char::Latin7::reverse(@) {
2673              
2674 0 0   0 0   if (wantarray) {
2675 0           return CORE::reverse @_;
2676             }
2677             else {
2678              
2679             # One of us once cornered Larry in an elevator and asked him what
2680             # problem he was solving with this, but he looked as far off into
2681             # the distance as he could in an elevator and said, "It seemed like
2682             # a good idea at the time."
2683              
2684 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2685             }
2686             }
2687              
2688             #
2689             # Latin-7 getc (with parameter, without parameter)
2690             #
2691             sub Char::Latin7::getc(;*@) {
2692              
2693 0     0 0   my($package) = caller;
2694 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2695 0 0 0       croak 'Too many arguments for Char::Latin7::getc' if @_ and not wantarray;
2696              
2697 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2698 0           my $getc = '';
2699 0           for my $length ($length[0] .. $length[-1]) {
2700 0           $getc .= CORE::getc($fh);
2701 0 0         if (exists $range_tr{CORE::length($getc)}) {
2702 0 0         if ($getc =~ /\A ${Char::Elatin7::dot_s} \z/oxms) {
2703 0 0         return wantarray ? ($getc,@_) : $getc;
2704             }
2705             }
2706             }
2707 0 0         return wantarray ? ($getc,@_) : $getc;
2708             }
2709              
2710             #
2711             # Latin-7 length by character
2712             #
2713             sub Char::Latin7::length(;$) {
2714              
2715 0 0   0 1   local $_ = shift if @_;
2716              
2717 0           local @_ = /\G ($q_char) /oxmsg;
2718 0           return scalar @_;
2719             }
2720              
2721             #
2722             # Latin-7 substr by character
2723             #
2724             BEGIN {
2725              
2726             # P.232 The lvalue Attribute
2727             # in Chapter 6: Subroutines
2728             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2729              
2730             # P.336 The lvalue Attribute
2731             # in Chapter 7: Subroutines
2732             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2733              
2734             # P.144 8.4 Lvalue subroutines
2735             # in Chapter 8: perlsub: Perl subroutines
2736             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2737              
2738 197 50 0 197 1 151324 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            
2739             # vv----------------*******
2740             sub Char::Latin7::substr($$;$$) %s {
2741              
2742             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2743              
2744             # If the substring is beyond either end of the string, substr() returns the undefined
2745             # value and produces a warning. When used as an lvalue, specifying a substring that
2746             # is entirely outside the string raises an exception.
2747             # http://perldoc.perl.org/functions/substr.html
2748              
2749             # A return with no argument returns the scalar value undef in scalar context,
2750             # an empty list () in list context, and (naturally) nothing at all in void
2751             # context.
2752              
2753             my $offset = $_[1];
2754             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2755             return;
2756             }
2757              
2758             # substr($string,$offset,$length,$replacement)
2759             if (@_ == 4) {
2760             my(undef,undef,$length,$replacement) = @_;
2761             my $substr = join '', splice(@char, $offset, $length, $replacement);
2762             $_[0] = join '', @char;
2763              
2764             # return $substr; this doesn't work, don't say "return"
2765             $substr;
2766             }
2767              
2768             # substr($string,$offset,$length)
2769             elsif (@_ == 3) {
2770             my(undef,undef,$length) = @_;
2771             my $octet_offset = 0;
2772             my $octet_length = 0;
2773             if ($offset == 0) {
2774             $octet_offset = 0;
2775             }
2776             elsif ($offset > 0) {
2777             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2778             }
2779             else {
2780             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2781             }
2782             if ($length == 0) {
2783             $octet_length = 0;
2784             }
2785             elsif ($length > 0) {
2786             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2787             }
2788             else {
2789             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2790             }
2791             CORE::substr($_[0], $octet_offset, $octet_length);
2792             }
2793              
2794             # substr($string,$offset)
2795             else {
2796             my $octet_offset = 0;
2797             if ($offset == 0) {
2798             $octet_offset = 0;
2799             }
2800             elsif ($offset > 0) {
2801             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2802             }
2803             else {
2804             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2805             }
2806             CORE::substr($_[0], $octet_offset);
2807             }
2808             }
2809             END
2810             }
2811              
2812             #
2813             # Latin-7 index by character
2814             #
2815             sub Char::Latin7::index($$;$) {
2816              
2817 0     0 1   my $index;
2818 0 0         if (@_ == 3) {
2819 0           $index = Char::Elatin7::index($_[0], $_[1], CORE::length(Char::Latin7::substr($_[0], 0, $_[2])));
2820             }
2821             else {
2822 0           $index = Char::Elatin7::index($_[0], $_[1]);
2823             }
2824              
2825 0 0         if ($index == -1) {
2826 0           return -1;
2827             }
2828             else {
2829 0           return Char::Latin7::length(CORE::substr $_[0], 0, $index);
2830             }
2831             }
2832              
2833             #
2834             # Latin-7 rindex by character
2835             #
2836             sub Char::Latin7::rindex($$;$) {
2837              
2838 0     0 1   my $rindex;
2839 0 0         if (@_ == 3) {
2840 0           $rindex = Char::Elatin7::rindex($_[0], $_[1], CORE::length(Char::Latin7::substr($_[0], 0, $_[2])));
2841             }
2842             else {
2843 0           $rindex = Char::Elatin7::rindex($_[0], $_[1]);
2844             }
2845              
2846 0 0         if ($rindex == -1) {
2847 0           return -1;
2848             }
2849             else {
2850 0           return Char::Latin7::length(CORE::substr $_[0], 0, $rindex);
2851             }
2852             }
2853              
2854             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2855             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2856 197     197   30187 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  197     197   2053  
  197         702  
  197         16178  
2857              
2858             # ord() to ord() or Char::Latin7::ord()
2859 197     197   13786 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  197     197   1170  
  197         422  
  197         13015  
2860              
2861             # ord to ord or Char::Latin7::ord_
2862 197     197   13018 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  197     197   1090  
  197         404  
  197         12440  
2863              
2864             # reverse to reverse or Char::Latin7::reverse
2865 197     197   11392 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  197     197   1072  
  197         371  
  197         12438  
2866              
2867             # getc to getc or Char::Latin7::getc
2868 197     197   11873 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  197     197   1102  
  197         368  
  197         19549  
2869              
2870             # P.1023 Appendix W.9 Multibyte Anchoring
2871             # of ISBN 1-56592-224-7 CJKV Information Processing
2872              
2873             my $anchor = '';
2874              
2875 197     197   13464 BEGIN { CORE::eval q{ use vars qw($nest) } }
  197     197   1304  
  197         405  
  197         11938643  
2876              
2877             # regexp of nested parens in qqXX
2878              
2879             # P.340 Matching Nested Constructs with Embedded Code
2880             # in Chapter 7: Perl
2881             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2882              
2883             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2884             \\c[\x40-\x5F] |
2885             \\ [\x00-\xFF] |
2886             [^()] |
2887             \( (?{$nest++}) |
2888             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2889             }xms;
2890             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2891             \\c[\x40-\x5F] |
2892             \\ [\x00-\xFF] |
2893             [^{}] |
2894             \{ (?{$nest++}) |
2895             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2896             }xms;
2897             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2898             \\c[\x40-\x5F] |
2899             \\ [\x00-\xFF] |
2900             [^[\]] |
2901             \[ (?{$nest++}) |
2902             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2903             }xms;
2904             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2905             \\c[\x40-\x5F] |
2906             \\ [\x00-\xFF] |
2907             [^<>] |
2908             \< (?{$nest++}) |
2909             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2910             }xms;
2911             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2912             (?: ::)? (?:
2913             [a-zA-Z_][a-zA-Z_0-9]*
2914             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2915             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2916             ))
2917             }xms;
2918             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2919             (?: ::)? (?:
2920             [0-9]+ |
2921             [^a-zA-Z_0-9\[\]] |
2922             ^[A-Z] |
2923             [a-zA-Z_][a-zA-Z_0-9]*
2924             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2925             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2926             ))
2927             }xms;
2928             my $qq_substr = qr{(?: Char::Latin7::substr | CORE::substr | substr ) \( $qq_paren \)
2929             }xms;
2930              
2931             # regexp of nested parens in qXX
2932             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2933             [^()] |
2934             \( (?{$nest++}) |
2935             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2936             }xms;
2937             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2938             [^{}] |
2939             \{ (?{$nest++}) |
2940             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2941             }xms;
2942             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2943             [^[\]] |
2944             \[ (?{$nest++}) |
2945             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2946             }xms;
2947             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2948             [^<>] |
2949             \< (?{$nest++}) |
2950             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2951             }xms;
2952              
2953             my $matched = '';
2954             my $s_matched = '';
2955              
2956             my $tr_variable = ''; # variable of tr///
2957             my $sub_variable = ''; # variable of s///
2958             my $bind_operator = ''; # =~ or !~
2959              
2960             my @heredoc = (); # here document
2961             my @heredoc_delimiter = ();
2962             my $here_script = ''; # here script
2963              
2964             #
2965             # escape Latin-7 script
2966             #
2967             sub Char::Latin7::escape(;$) {
2968 0 0   0 0   local($_) = $_[0] if @_;
2969              
2970             # P.359 The Study Function
2971             # in Chapter 7: Perl
2972             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2973              
2974 0           study $_; # Yes, I studied study yesterday.
2975              
2976             # while all script
2977              
2978             # 6.14. Matching from Where the Last Pattern Left Off
2979             # in Chapter 6. Pattern Matching
2980             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2981             # (and so on)
2982              
2983             # one member of Tag-team
2984             #
2985             # P.128 Start of match (or end of previous match): \G
2986             # P.130 Advanced Use of \G with Perl
2987             # in Chapter 3: Overview of Regular Expression Features and Flavors
2988             # P.255 Use leading anchors
2989             # P.256 Expose ^ and \G at the front expressions
2990             # in Chapter 6: Crafting an Efficient Expression
2991             # P.315 "Tag-team" matching with /gc
2992             # in Chapter 7: Perl
2993             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2994              
2995 0           my $e_script = '';
2996 0           while (not /\G \z/oxgc) { # member
2997 0           $e_script .= Char::Latin7::escape_token();
2998             }
2999              
3000 0           return $e_script;
3001             }
3002              
3003             #
3004             # escape Latin-7 token of script
3005             #
3006             sub Char::Latin7::escape_token {
3007              
3008             # \n output here document
3009              
3010 0     0 0   my $ignore_modules = join('|', qw(
3011             utf8
3012             bytes
3013             charnames
3014             I18N::Japanese
3015             I18N::Collate
3016             I18N::JExt
3017             File::DosGlob
3018             Wild
3019             Wildcard
3020             Japanese
3021             ));
3022              
3023             # another member of Tag-team
3024             #
3025             # P.315 "Tag-team" matching with /gc
3026             # in Chapter 7: Perl
3027             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3028              
3029 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          
3030 0           my $heredoc = '';
3031 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3032 0           $slash = 'm//';
3033              
3034 0           $heredoc = join '', @heredoc;
3035 0           @heredoc = ();
3036              
3037             # skip here document
3038 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3039 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3040             }
3041 0           @heredoc_delimiter = ();
3042              
3043 0           $here_script = '';
3044             }
3045 0           return "\n" . $heredoc;
3046             }
3047              
3048             # ignore space, comment
3049 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
3050              
3051             # if (, elsif (, unless (, while (, until (, given (, and when (
3052              
3053             # given, when
3054              
3055             # P.225 The given Statement
3056             # in Chapter 15: Smart Matching and given-when
3057             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3058              
3059             # P.133 The given Statement
3060             # in Chapter 4: Statements and Declarations
3061             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3062              
3063             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
3064 0           $slash = 'm//';
3065 0           return $1;
3066             }
3067              
3068             # scalar variable ($scalar = ...) =~ tr///;
3069             # scalar variable ($scalar = ...) =~ s///;
3070              
3071             # state
3072              
3073             # P.68 Persistent, Private Variables
3074             # in Chapter 4: Subroutines
3075             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3076              
3077             # P.160 Persistent Lexically Scoped Variables: state
3078             # in Chapter 4: Statements and Declarations
3079             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3080              
3081             # (and so on)
3082              
3083             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
3084 0           my $e_string = e_string($1);
3085              
3086 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3087 0           $tr_variable = $e_string . e_string($1);
3088 0           $bind_operator = $2;
3089 0           $slash = 'm//';
3090 0           return '';
3091             }
3092             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3093 0           $sub_variable = $e_string . e_string($1);
3094 0           $bind_operator = $2;
3095 0           $slash = 'm//';
3096 0           return '';
3097             }
3098             else {
3099 0           $slash = 'div';
3100 0           return $e_string;
3101             }
3102             }
3103              
3104             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin7::PREMATCH()
3105             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
3106 0           $slash = 'div';
3107 0           return q{Char::Elatin7::PREMATCH()};
3108             }
3109              
3110             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin7::MATCH()
3111             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
3112 0           $slash = 'div';
3113 0           return q{Char::Elatin7::MATCH()};
3114             }
3115              
3116             # $', ${'} --> $', ${'}
3117             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3118 0           $slash = 'div';
3119 0           return $1;
3120             }
3121              
3122             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin7::POSTMATCH()
3123             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
3124 0           $slash = 'div';
3125 0           return q{Char::Elatin7::POSTMATCH()};
3126             }
3127              
3128             # scalar variable $scalar =~ tr///;
3129             # scalar variable $scalar =~ s///;
3130             # substr() =~ tr///;
3131             # substr() =~ s///;
3132             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3133 0           my $scalar = e_string($1);
3134              
3135 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3136 0           $tr_variable = $scalar;
3137 0           $bind_operator = $1;
3138 0           $slash = 'm//';
3139 0           return '';
3140             }
3141             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3142 0           $sub_variable = $scalar;
3143 0           $bind_operator = $1;
3144 0           $slash = 'm//';
3145 0           return '';
3146             }
3147             else {
3148 0           $slash = 'div';
3149 0           return $scalar;
3150             }
3151             }
3152              
3153             # end of statement
3154             elsif (/\G ( [,;] ) /oxgc) {
3155 0           $slash = 'm//';
3156              
3157             # clear tr/// variable
3158 0           $tr_variable = '';
3159              
3160             # clear s/// variable
3161 0           $sub_variable = '';
3162              
3163 0           $bind_operator = '';
3164              
3165 0           return $1;
3166             }
3167              
3168             # bareword
3169             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
3170 0           return $1;
3171             }
3172              
3173             # $0 --> $0
3174             elsif (/\G ( \$ 0 ) /oxmsgc) {
3175 0           $slash = 'div';
3176 0           return $1;
3177             }
3178             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
3179 0           $slash = 'div';
3180 0           return $1;
3181             }
3182              
3183             # $$ --> $$
3184             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3185 0           $slash = 'div';
3186 0           return $1;
3187             }
3188              
3189             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3190             # $1, $2, $3 --> $1, $2, $3 otherwise
3191             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
3192 0           $slash = 'div';
3193 0           return e_capture($1);
3194             }
3195             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
3196 0           $slash = 'div';
3197 0           return e_capture($1);
3198             }
3199              
3200             # $$foo[ ... ] --> $ $foo->[ ... ]
3201             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
3202 0           $slash = 'div';
3203 0           return e_capture($1.'->'.$2);
3204             }
3205              
3206             # $$foo{ ... } --> $ $foo->{ ... }
3207             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
3208 0           $slash = 'div';
3209 0           return e_capture($1.'->'.$2);
3210             }
3211              
3212             # $$foo
3213             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
3214 0           $slash = 'div';
3215 0           return e_capture($1);
3216             }
3217              
3218             # ${ foo }
3219             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
3220 0           $slash = 'div';
3221 0           return '${' . $1 . '}';
3222             }
3223              
3224             # ${ ... }
3225             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
3226 0           $slash = 'div';
3227 0           return e_capture($1);
3228             }
3229              
3230             # variable or function
3231             # $ @ % & * $ #
3232             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) {
3233 0           $slash = 'div';
3234 0           return $1;
3235             }
3236             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3237             # $ @ # \ ' " / ? ( ) [ ] < >
3238             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3239 0           $slash = 'div';
3240 0           return $1;
3241             }
3242              
3243             # while ()
3244             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
3245 0           return $1;
3246             }
3247              
3248             # while () --- glob
3249              
3250             # avoid "Error: Runtime exception" of perl version 5.005_03
3251              
3252             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
3253 0           return 'while ($_ = Char::Elatin7::glob("' . $1 . '"))';
3254             }
3255              
3256             # while (glob)
3257             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
3258 0           return 'while ($_ = Char::Elatin7::glob_)';
3259             }
3260              
3261             # while (glob(WILDCARD))
3262             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
3263 0           return 'while ($_ = Char::Elatin7::glob';
3264             }
3265              
3266             # doit if, doit unless, doit while, doit until, doit for, doit when
3267 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3268              
3269             # subroutines of package Char::Elatin7
3270 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3271 0           elsif (/\G \b Char::Latin7::eval (?= \s* \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3272 0           elsif (/\G \b Char::Latin7::eval \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'eval Char::Latin7::escape'; }
  0            
3273 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3274 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::chop'; }
  0            
3275 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3276 0           elsif (/\G \b Char::Latin7::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin7::index'; }
  0            
3277 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::index'; }
  0            
3278 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3279 0           elsif (/\G \b Char::Latin7::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Latin7::rindex'; }
  0            
3280 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::rindex'; }
  0            
3281 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::lc'; }
  0            
3282 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::lcfirst'; }
  0            
3283 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::uc'; }
  0            
3284 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::ucfirst'; }
  0            
3285 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::fc'; }
  0            
3286              
3287             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3288 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3289 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3290 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3291 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3292 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3293 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3294 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3295              
3296 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3297 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3298 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3299 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3300 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3301 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3302 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3303              
3304             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3305 0           { $slash = 'm//'; return "-s $1"; }
  0            
3306 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3307 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3308 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3309              
3310 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3311 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3312 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::chr'; }
  0            
3313 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3314 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3315 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::glob'; }
  0            
3316 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::lc_'; }
  0            
3317 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::lcfirst_'; }
  0            
3318 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::uc_'; }
  0            
3319 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::ucfirst_'; }
  0            
3320 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::fc_'; }
  0            
3321 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3322              
3323 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3324 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3325 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::chr_'; }
  0            
3326 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3327 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3328 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Elatin7::glob_'; }
  0            
3329 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3330 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3331             # split
3332             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
3333 0           $slash = 'm//';
3334              
3335 0           my $e = '';
3336 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
3337 0           $e .= $1;
3338             }
3339              
3340             # end of split
3341 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin7::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          
3342              
3343             # split scalar value
3344 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Elatin7::split' . $e . e_string($1); }
3345              
3346             # split literal space
3347 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Elatin7::split' . $e . qq {qq$1 $2}; }
3348 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; }
3349 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; }
3350 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; }
3351 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; }
3352 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; }
3353 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Elatin7::split' . $e . qq {q$1 $2}; }
3354 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; }
3355 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; }
3356 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; }
3357 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; }
3358 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; }
3359 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Elatin7::split' . $e . qq {' '}; }
3360 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Elatin7::split' . $e . qq {" "}; }
3361              
3362             # split qq//
3363             elsif (/\G \b (qq) \b /oxgc) {
3364 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3365             else {
3366 0           while (not /\G \z/oxgc) {
3367 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3368 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3369 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3370 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3371 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3372 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3373 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3374             }
3375 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3376             }
3377             }
3378              
3379             # split qr//
3380             elsif (/\G \b (qr) \b /oxgc) {
3381 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3382             else {
3383 0           while (not /\G \z/oxgc) {
3384 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3385 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3386 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3387 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3388 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3389 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3390 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3391 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3392             }
3393 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3394             }
3395             }
3396              
3397             # split q//
3398             elsif (/\G \b (q) \b /oxgc) {
3399 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> 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          
3403 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3404 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3405 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3406 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3407 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3408 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3409             }
3410 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3411             }
3412             }
3413              
3414             # split m//
3415             elsif (/\G \b (m) \b /oxgc) {
3416 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3417             else {
3418 0           while (not /\G \z/oxgc) {
3419 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3420 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3421 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3422 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3423 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3424 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3425 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3426 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3427             }
3428 0           die __FILE__, ": Search pattern not terminated";
3429             }
3430             }
3431              
3432             # split ''
3433             elsif (/\G (\') /oxgc) {
3434 0           my $q_string = '';
3435 0           while (not /\G \z/oxgc) {
3436 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3437 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3438 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3439 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3440             }
3441 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3442             }
3443              
3444             # split ""
3445             elsif (/\G (\") /oxgc) {
3446 0           my $qq_string = '';
3447 0           while (not /\G \z/oxgc) {
3448 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3449 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3450 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3451 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3452             }
3453 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3454             }
3455              
3456             # split //
3457             elsif (/\G (\/) /oxgc) {
3458 0           my $regexp = '';
3459 0           while (not /\G \z/oxgc) {
3460 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3461 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3462 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3463 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3464             }
3465 0           die __FILE__, ": Search pattern not terminated";
3466             }
3467             }
3468              
3469             # tr/// or y///
3470              
3471             # about [cdsrbB]* (/B modifier)
3472             #
3473             # P.559 appendix C
3474             # of ISBN 4-89052-384-7 Programming perl
3475             # (Japanese title is: Perl puroguramingu)
3476              
3477             elsif (/\G \b ( tr | y ) \b /oxgc) {
3478 0           my $ope = $1;
3479              
3480             # $1 $2 $3 $4 $5 $6
3481 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3482 0           my @tr = ($tr_variable,$2);
3483 0           return e_tr(@tr,'',$4,$6);
3484             }
3485             else {
3486 0           my $e = '';
3487 0           while (not /\G \z/oxgc) {
3488 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3489             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3490 0           my @tr = ($tr_variable,$2);
3491 0           while (not /\G \z/oxgc) {
3492 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3493 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3494 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3495 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3496 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3497 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3498             }
3499 0           die __FILE__, ": Transliteration replacement not terminated";
3500             }
3501             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3502 0           my @tr = ($tr_variable,$2);
3503 0           while (not /\G \z/oxgc) {
3504 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3505 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3506 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3507 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3508 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3509 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3510             }
3511 0           die __FILE__, ": Transliteration replacement not terminated";
3512             }
3513             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3514 0           my @tr = ($tr_variable,$2);
3515 0           while (not /\G \z/oxgc) {
3516 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3517 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3518 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3519 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3520 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3521 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3522             }
3523 0           die __FILE__, ": Transliteration replacement not terminated";
3524             }
3525             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3526 0           my @tr = ($tr_variable,$2);
3527 0           while (not /\G \z/oxgc) {
3528 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3529 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3530 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3531 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3532 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3533 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3534             }
3535 0           die __FILE__, ": Transliteration replacement not terminated";
3536             }
3537             # $1 $2 $3 $4 $5 $6
3538             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3539 0           my @tr = ($tr_variable,$2);
3540 0           return e_tr(@tr,'',$4,$6);
3541             }
3542             }
3543 0           die __FILE__, ": Transliteration pattern not terminated";
3544             }
3545             }
3546              
3547             # qq//
3548             elsif (/\G \b (qq) \b /oxgc) {
3549 0           my $ope = $1;
3550              
3551             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3552 0 0         if (/\G (\#) /oxgc) { # qq# #
3553 0           my $qq_string = '';
3554 0           while (not /\G \z/oxgc) {
3555 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3556 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3557 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3558 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3559             }
3560 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3561             }
3562              
3563             else {
3564 0           my $e = '';
3565 0           while (not /\G \z/oxgc) {
3566 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3567              
3568             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3569             elsif (/\G (\() /oxgc) { # qq ( )
3570 0           my $qq_string = '';
3571 0           local $nest = 1;
3572 0           while (not /\G \z/oxgc) {
3573 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3574 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3575 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3576             elsif (/\G (\)) /oxgc) {
3577 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3578 0           else { $qq_string .= $1; }
3579             }
3580 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3581             }
3582 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3583             }
3584              
3585             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3586             elsif (/\G (\{) /oxgc) { # qq { }
3587 0           my $qq_string = '';
3588 0           local $nest = 1;
3589 0           while (not /\G \z/oxgc) {
3590 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3591 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3592 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3593             elsif (/\G (\}) /oxgc) {
3594 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3595 0           else { $qq_string .= $1; }
3596             }
3597 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3598             }
3599 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3600             }
3601              
3602             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3603             elsif (/\G (\[) /oxgc) { # qq [ ]
3604 0           my $qq_string = '';
3605 0           local $nest = 1;
3606 0           while (not /\G \z/oxgc) {
3607 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3608 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3609 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3610             elsif (/\G (\]) /oxgc) {
3611 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3612 0           else { $qq_string .= $1; }
3613             }
3614 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3615             }
3616 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3617             }
3618              
3619             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3620             elsif (/\G (\<) /oxgc) { # qq < >
3621 0           my $qq_string = '';
3622 0           local $nest = 1;
3623 0           while (not /\G \z/oxgc) {
3624 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3625 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3626 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3627             elsif (/\G (\>) /oxgc) {
3628 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3629 0           else { $qq_string .= $1; }
3630             }
3631 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3632             }
3633 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3634             }
3635              
3636             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3637             elsif (/\G (\S) /oxgc) { # qq * *
3638 0           my $delimiter = $1;
3639 0           my $qq_string = '';
3640 0           while (not /\G \z/oxgc) {
3641 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3642 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3643 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3644 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3645             }
3646 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3647             }
3648             }
3649 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3650             }
3651             }
3652              
3653             # qr//
3654             elsif (/\G \b (qr) \b /oxgc) {
3655 0           my $ope = $1;
3656 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
3657 0           return e_qr($ope,$1,$3,$2,$4);
3658             }
3659             else {
3660 0           my $e = '';
3661 0           while (not /\G \z/oxgc) {
3662 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3663 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3664 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3665 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3666 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3667 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3668 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3669 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3670             }
3671 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3672             }
3673             }
3674              
3675             # qw//
3676             elsif (/\G \b (qw) \b /oxgc) {
3677 0           my $ope = $1;
3678 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3679 0           return e_qw($ope,$1,$3,$2);
3680             }
3681             else {
3682 0           my $e = '';
3683 0           while (not /\G \z/oxgc) {
3684 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3685              
3686 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3687 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3688              
3689 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3690 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3691              
3692 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3693 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3694              
3695 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3696 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3697              
3698 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3699 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3700             }
3701 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3702             }
3703             }
3704              
3705             # qx//
3706             elsif (/\G \b (qx) \b /oxgc) {
3707 0           my $ope = $1;
3708 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3709 0           return e_qq($ope,$1,$3,$2);
3710             }
3711             else {
3712 0           my $e = '';
3713 0           while (not /\G \z/oxgc) {
3714 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3715 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3716 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3717 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3718 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3719 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3720 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3721             }
3722 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3723             }
3724             }
3725              
3726             # q//
3727             elsif (/\G \b (q) \b /oxgc) {
3728 0           my $ope = $1;
3729              
3730             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3731              
3732             # avoid "Error: Runtime exception" of perl version 5.005_03
3733             # (and so on)
3734              
3735 0 0         if (/\G (\#) /oxgc) { # q# #
3736 0           my $q_string = '';
3737 0           while (not /\G \z/oxgc) {
3738 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3739 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3740 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3741 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3742             }
3743 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3744             }
3745              
3746             else {
3747 0           my $e = '';
3748 0           while (not /\G \z/oxgc) {
3749 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3750              
3751             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3752             elsif (/\G (\() /oxgc) { # q ( )
3753 0           my $q_string = '';
3754 0           local $nest = 1;
3755 0           while (not /\G \z/oxgc) {
3756 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3757 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3758 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3759 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3760             elsif (/\G (\)) /oxgc) {
3761 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3762 0           else { $q_string .= $1; }
3763             }
3764 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3765             }
3766 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3767             }
3768              
3769             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /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_bracket)*?) (\]) /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_angle)*?) (\>) /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 (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3824             elsif (/\G (\S) /oxgc) { # q * *
3825 0           my $delimiter = $1;
3826 0           my $q_string = '';
3827 0           while (not /\G \z/oxgc) {
3828 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3829 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3830 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3831 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3832             }
3833 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3834             }
3835             }
3836 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3837             }
3838             }
3839              
3840             # m//
3841             elsif (/\G \b (m) \b /oxgc) {
3842 0           my $ope = $1;
3843 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
3844 0           return e_qr($ope,$1,$3,$2,$4);
3845             }
3846             else {
3847 0           my $e = '';
3848 0           while (not /\G \z/oxgc) {
3849 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3850 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3851 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3852 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3853 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3854 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3855 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3856 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3857 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3858             }
3859 0           die __FILE__, ": Search pattern not terminated";
3860             }
3861             }
3862              
3863             # s///
3864              
3865             # about [cegimosxpradlubB]* (/cg modifier)
3866             #
3867             # P.67 Pattern-Matching Operators
3868             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3869              
3870             elsif (/\G \b (s) \b /oxgc) {
3871 0           my $ope = $1;
3872              
3873             # $1 $2 $3 $4 $5 $6
3874 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
3875 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3876             }
3877             else {
3878 0           my $e = '';
3879 0           while (not /\G \z/oxgc) {
3880 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3881             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3882 0           my @s = ($1,$2,$3);
3883 0           while (not /\G \z/oxgc) {
3884 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3885             # $1 $2 $3 $4
3886 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3887 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3888 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3889 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3890 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3891 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3892 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3893 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3894 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3895             }
3896 0           die __FILE__, ": Substitution replacement not terminated";
3897             }
3898             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3899 0           my @s = ($1,$2,$3);
3900 0           while (not /\G \z/oxgc) {
3901 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3902             # $1 $2 $3 $4
3903 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3904 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3905 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3906 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3907 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([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 (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912             }
3913 0           die __FILE__, ": Substitution replacement not terminated";
3914             }
3915             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3916 0           my @s = ($1,$2,$3);
3917 0           while (not /\G \z/oxgc) {
3918 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3919             # $1 $2 $3 $4
3920 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3921 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3922 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3923 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927             }
3928 0           die __FILE__, ": Substitution replacement not terminated";
3929             }
3930             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3931 0           my @s = ($1,$2,$3);
3932 0           while (not /\G \z/oxgc) {
3933 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3934             # $1 $2 $3 $4
3935 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3939 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944             }
3945 0           die __FILE__, ": Substitution replacement not terminated";
3946             }
3947             # $1 $2 $3 $4 $5 $6
3948             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
3949 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3950             }
3951             # $1 $2 $3 $4 $5 $6
3952             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3953 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3954             }
3955             # $1 $2 $3 $4 $5 $6
3956             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3957 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3958             }
3959             # $1 $2 $3 $4 $5 $6
3960             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3961 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3962             }
3963             }
3964 0           die __FILE__, ": Substitution pattern not terminated";
3965             }
3966             }
3967              
3968             # require ignore module
3969 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3970 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3971 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3972              
3973             # use strict; --> use strict; no strict qw(refs);
3974 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3975 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3976 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3977              
3978             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
3979             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3980 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
3981 0           return "use $1; no strict qw(refs);";
3982             }
3983             else {
3984 0           return "use $1;";
3985             }
3986             }
3987             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3988 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
3989 0           return "use $1; no strict qw(refs);";
3990             }
3991             else {
3992 0           return "use $1;";
3993             }
3994             }
3995              
3996             # ignore use module
3997 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3998 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3999 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4000              
4001             # ignore no module
4002 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4003 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4004 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4005              
4006             # use else
4007 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4008              
4009             # use else
4010 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4011              
4012             # ''
4013             elsif (/\G (?
4014 0           my $q_string = '';
4015 0           while (not /\G \z/oxgc) {
4016 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4017 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4018 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4019 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4020             }
4021 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4022             }
4023              
4024             # ""
4025             elsif (/\G (\") /oxgc) {
4026 0           my $qq_string = '';
4027 0           while (not /\G \z/oxgc) {
4028 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4029 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4030 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4031 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4032             }
4033 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4034             }
4035              
4036             # ``
4037             elsif (/\G (\`) /oxgc) {
4038 0           my $qx_string = '';
4039 0           while (not /\G \z/oxgc) {
4040 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4041 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4042 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4043 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4044             }
4045 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4046             }
4047              
4048             # // --- not divide operator (num / num), not defined-or
4049             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4050 0           my $regexp = '';
4051 0           while (not /\G \z/oxgc) {
4052 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4053 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4054 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4055 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4056             }
4057 0           die __FILE__, ": Search pattern not terminated";
4058             }
4059              
4060             # ?? --- not conditional operator (condition ? then : else)
4061             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4062 0           my $regexp = '';
4063 0           while (not /\G \z/oxgc) {
4064 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4065 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4066 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4067 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4068             }
4069 0           die __FILE__, ": Search pattern not terminated";
4070             }
4071              
4072             # << (bit shift) --- not here document
4073 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4074              
4075             # <<'HEREDOC'
4076             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4077 0           $slash = 'm//';
4078 0           my $here_quote = $1;
4079 0           my $delimiter = $2;
4080              
4081             # get here document
4082 0 0         if ($here_script eq '') {
4083 0           $here_script = CORE::substr $_, pos $_;
4084 0           $here_script =~ s/.*?\n//oxm;
4085             }
4086 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4087 0           push @heredoc, $1 . qq{\n$delimiter\n};
4088 0           push @heredoc_delimiter, $delimiter;
4089             }
4090             else {
4091 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4092             }
4093 0           return $here_quote;
4094             }
4095              
4096             # <<\HEREDOC
4097              
4098             # P.66 2.6.6. "Here" Documents
4099             # in Chapter 2: Bits and Pieces
4100             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4101              
4102             # P.73 "Here" Documents
4103             # in Chapter 2: Bits and Pieces
4104             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4105              
4106             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4107 0           $slash = 'm//';
4108 0           my $here_quote = $1;
4109 0           my $delimiter = $2;
4110              
4111             # get here document
4112 0 0         if ($here_script eq '') {
4113 0           $here_script = CORE::substr $_, pos $_;
4114 0           $here_script =~ s/.*?\n//oxm;
4115             }
4116 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4117 0           push @heredoc, $1 . qq{\n$delimiter\n};
4118 0           push @heredoc_delimiter, $delimiter;
4119             }
4120             else {
4121 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4122             }
4123 0           return $here_quote;
4124             }
4125              
4126             # <<"HEREDOC"
4127             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4128 0           $slash = 'm//';
4129 0           my $here_quote = $1;
4130 0           my $delimiter = $2;
4131              
4132             # get here document
4133 0 0         if ($here_script eq '') {
4134 0           $here_script = CORE::substr $_, pos $_;
4135 0           $here_script =~ s/.*?\n//oxm;
4136             }
4137 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4138 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4139 0           push @heredoc_delimiter, $delimiter;
4140             }
4141             else {
4142 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4143             }
4144 0           return $here_quote;
4145             }
4146              
4147             # <
4148             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4149 0           $slash = 'm//';
4150 0           my $here_quote = $1;
4151 0           my $delimiter = $2;
4152              
4153             # get here document
4154 0 0         if ($here_script eq '') {
4155 0           $here_script = CORE::substr $_, pos $_;
4156 0           $here_script =~ s/.*?\n//oxm;
4157             }
4158 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4159 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4160 0           push @heredoc_delimiter, $delimiter;
4161             }
4162             else {
4163 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4164             }
4165 0           return $here_quote;
4166             }
4167              
4168             # <<`HEREDOC`
4169             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4170 0           $slash = 'm//';
4171 0           my $here_quote = $1;
4172 0           my $delimiter = $2;
4173              
4174             # get here document
4175 0 0         if ($here_script eq '') {
4176 0           $here_script = CORE::substr $_, pos $_;
4177 0           $here_script =~ s/.*?\n//oxm;
4178             }
4179 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4180 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4181 0           push @heredoc_delimiter, $delimiter;
4182             }
4183             else {
4184 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4185             }
4186 0           return $here_quote;
4187             }
4188              
4189             # <<= <=> <= < operator
4190             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4191 0           return $1;
4192             }
4193              
4194             #
4195             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4196 0           return $1;
4197             }
4198              
4199             # --- glob
4200              
4201             # avoid "Error: Runtime exception" of perl version 5.005_03
4202              
4203             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4204 0           return 'Char::Elatin7::glob("' . $1 . '")';
4205             }
4206              
4207             # __DATA__
4208 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4209              
4210             # __END__
4211 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4212              
4213             # \cD Control-D
4214              
4215             # P.68 2.6.8. Other Literal Tokens
4216             # in Chapter 2: Bits and Pieces
4217             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4218              
4219             # P.76 Other Literal Tokens
4220             # in Chapter 2: Bits and Pieces
4221             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4222              
4223 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4224              
4225             # \cZ Control-Z
4226 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4227              
4228             # any operator before div
4229             elsif (/\G (
4230             -- | \+\+ |
4231             [\)\}\]]
4232              
4233 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4234              
4235             # yada-yada or triple-dot operator
4236             elsif (/\G (
4237             \.\.\.
4238              
4239 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4240              
4241             # any operator before m//
4242              
4243             # //, //= (defined-or)
4244              
4245             # P.164 Logical Operators
4246             # in Chapter 10: More Control Structures
4247             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4248              
4249             # P.119 C-Style Logical (Short-Circuit) Operators
4250             # in Chapter 3: Unary and Binary Operators
4251             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4252              
4253             # (and so on)
4254              
4255             # ~~
4256              
4257             # P.221 The Smart Match Operator
4258             # in Chapter 15: Smart Matching and given-when
4259             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4260              
4261             # P.112 Smartmatch Operator
4262             # in Chapter 3: Unary and Binary Operators
4263             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4264              
4265             # (and so on)
4266              
4267             elsif (/\G (
4268              
4269             !~~ | !~ | != | ! |
4270             %= | % |
4271             &&= | && | &= | & |
4272             -= | -> | - |
4273             :\s*= |
4274             : |
4275             <<= | <=> | <= | < |
4276             == | => | =~ | = |
4277             >>= | >> | >= | > |
4278             \*\*= | \*\* | \*= | \* |
4279             \+= | \+ |
4280             \.\. | \.= | \. |
4281             \/\/= | \/\/ |
4282             \/= | \/ |
4283             \? |
4284             \\ |
4285             \^= | \^ |
4286             \b x= |
4287             \|\|= | \|\| | \|= | \| |
4288             ~~ | ~ |
4289             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4290             \b(?: print )\b |
4291              
4292             [,;\(\{\[]
4293              
4294 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4295              
4296             # other any character
4297 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4298              
4299             # system error
4300             else {
4301 0           die __FILE__, ": Oops, this shouldn't happen!";
4302             }
4303             }
4304              
4305             # escape Latin-7 string
4306             sub e_string {
4307 0     0 0   my($string) = @_;
4308 0           my $e_string = '';
4309              
4310 0           local $slash = 'm//';
4311              
4312             # P.1024 Appendix W.10 Multibyte Processing
4313             # of ISBN 1-56592-224-7 CJKV Information Processing
4314             # (and so on)
4315              
4316 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
4317              
4318             # without { ... }
4319 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4320 0 0         if ($string !~ /<
4321 0           return $string;
4322             }
4323             }
4324              
4325             E_STRING_LOOP:
4326 0           while ($string !~ /\G \z/oxgc) {
4327 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          
4328             }
4329              
4330             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Elatin7::PREMATCH()]}
4331 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
4332 0           $e_string .= q{Char::Elatin7::PREMATCH()};
4333 0           $slash = 'div';
4334             }
4335              
4336             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Elatin7::MATCH()]}
4337             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
4338 0           $e_string .= q{Char::Elatin7::MATCH()};
4339 0           $slash = 'div';
4340             }
4341              
4342             # $', ${'} --> $', ${'}
4343             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4344 0           $e_string .= $1;
4345 0           $slash = 'div';
4346             }
4347              
4348             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Elatin7::POSTMATCH()]}
4349             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
4350 0           $e_string .= q{Char::Elatin7::POSTMATCH()};
4351 0           $slash = 'div';
4352             }
4353              
4354             # bareword
4355             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
4356 0           $e_string .= $1;
4357 0           $slash = 'div';
4358             }
4359              
4360             # $0 --> $0
4361             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4362 0           $e_string .= $1;
4363 0           $slash = 'div';
4364             }
4365             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
4366 0           $e_string .= $1;
4367 0           $slash = 'div';
4368             }
4369              
4370             # $$ --> $$
4371             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4372 0           $e_string .= $1;
4373 0           $slash = 'div';
4374             }
4375              
4376             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4377             # $1, $2, $3 --> $1, $2, $3 otherwise
4378             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
4379 0           $e_string .= e_capture($1);
4380 0           $slash = 'div';
4381             }
4382             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
4383 0           $e_string .= e_capture($1);
4384 0           $slash = 'div';
4385             }
4386              
4387             # $$foo[ ... ] --> $ $foo->[ ... ]
4388             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
4389 0           $e_string .= e_capture($1.'->'.$2);
4390 0           $slash = 'div';
4391             }
4392              
4393             # $$foo{ ... } --> $ $foo->{ ... }
4394             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
4395 0           $e_string .= e_capture($1.'->'.$2);
4396 0           $slash = 'div';
4397             }
4398              
4399             # $$foo
4400             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
4401 0           $e_string .= e_capture($1);
4402 0           $slash = 'div';
4403             }
4404              
4405             # ${ foo }
4406             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
4407 0           $e_string .= '${' . $1 . '}';
4408 0           $slash = 'div';
4409             }
4410              
4411             # ${ ... }
4412             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
4413 0           $e_string .= e_capture($1);
4414 0           $slash = 'div';
4415             }
4416              
4417             # variable or function
4418             # $ @ % & * $ #
4419             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) {
4420 0           $e_string .= $1;
4421 0           $slash = 'div';
4422             }
4423             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4424             # $ @ # \ ' " / ? ( ) [ ] < >
4425             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4426 0           $e_string .= $1;
4427 0           $slash = 'div';
4428             }
4429              
4430             # subroutines of package Char::Elatin7
4431 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4432 0           elsif ($string =~ /\G \b Char::Latin7::eval (?= \s* \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4433 0           elsif ($string =~ /\G \b Char::Latin7::eval \b /oxgc) { $e_string .= 'eval Char::Latin7::escape'; $slash = 'm//'; }
  0            
4434 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4435 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Elatin7::chop'; $slash = 'm//'; }
  0            
4436 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4437 0           elsif ($string =~ /\G \b Char::Latin7::index \b /oxgc) { $e_string .= 'Char::Latin7::index'; $slash = 'm//'; }
  0            
4438 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Elatin7::index'; $slash = 'm//'; }
  0            
4439 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4440 0           elsif ($string =~ /\G \b Char::Latin7::rindex \b /oxgc) { $e_string .= 'Char::Latin7::rindex'; $slash = 'm//'; }
  0            
4441 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Elatin7::rindex'; $slash = 'm//'; }
  0            
4442 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin7::lc'; $slash = 'm//'; }
  0            
4443 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin7::lcfirst'; $slash = 'm//'; }
  0            
4444 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin7::uc'; $slash = 'm//'; }
  0            
4445 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin7::ucfirst'; $slash = 'm//'; }
  0            
4446 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin7::fc'; $slash = 'm//'; }
  0            
4447              
4448             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4449 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4450 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4451 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4452 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4453 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4454 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4455 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            
4456              
4457 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4458 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4459 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4460 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4461 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4462 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4463 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            
4464              
4465             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
4466 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4467 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4468 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4469 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4470              
4471 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4472 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4473 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin7::chr'; $slash = 'm//'; }
  0            
4474 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4475 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4476 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Elatin7::glob'; $slash = 'm//'; }
  0            
4477 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Elatin7::lc_'; $slash = 'm//'; }
  0            
4478 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Elatin7::lcfirst_'; $slash = 'm//'; }
  0            
4479 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Elatin7::uc_'; $slash = 'm//'; }
  0            
4480 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Elatin7::ucfirst_'; $slash = 'm//'; }
  0            
4481 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Elatin7::fc_'; $slash = 'm//'; }
  0            
4482 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4483              
4484 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4485 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4486 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Elatin7::chr_'; $slash = 'm//'; }
  0            
4487 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4488 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4489 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Elatin7::glob_'; $slash = 'm//'; }
  0            
4490 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4491 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4492             # split
4493             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
4494 0           $slash = 'm//';
4495              
4496 0           my $e = '';
4497 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
4498 0           $e .= $1;
4499             }
4500              
4501             # end of split
4502 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Elatin7::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          
4503              
4504             # split scalar value
4505 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4506              
4507             # split literal space
4508 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4509 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4510 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4511 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4512 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4513 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4514 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4515 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4516 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4517 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4518 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4519 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4520 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4521 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Elatin7::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4522              
4523             # split qq//
4524             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4525 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            
4526             else {
4527 0           while ($string !~ /\G \z/oxgc) {
4528 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4529 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4530 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4531 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4532 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4533 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4534 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            
4535             }
4536 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4537             }
4538             }
4539              
4540             # split qr//
4541             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4542 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            
4543             else {
4544 0           while ($string !~ /\G \z/oxgc) {
4545 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4546 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4547 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4548 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4549 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4550 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            
4551 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4552 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            
4553             }
4554 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4555             }
4556             }
4557              
4558             # split q//
4559             elsif ($string =~ /\G \b (q) \b /oxgc) {
4560 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            
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          
4564 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4565 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4566 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4567 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4568 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4569 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            
4570             }
4571 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4572             }
4573             }
4574              
4575             # split m//
4576             elsif ($string =~ /\G \b (m) \b /oxgc) {
4577 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            
4578             else {
4579 0           while ($string !~ /\G \z/oxgc) {
4580 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4581 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            
4582 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            
4583 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            
4584 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            
4585 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            
4586 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4587 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            
4588             }
4589 0           die __FILE__, ": Search pattern not terminated";
4590             }
4591             }
4592              
4593             # split ''
4594             elsif ($string =~ /\G (\') /oxgc) {
4595 0           my $q_string = '';
4596 0           while ($string !~ /\G \z/oxgc) {
4597 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4598 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4599 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4600 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4601             }
4602 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4603             }
4604              
4605             # split ""
4606             elsif ($string =~ /\G (\") /oxgc) {
4607 0           my $qq_string = '';
4608 0           while ($string !~ /\G \z/oxgc) {
4609 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4610 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4611 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4612 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4613             }
4614 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4615             }
4616              
4617             # split //
4618             elsif ($string =~ /\G (\/) /oxgc) {
4619 0           my $regexp = '';
4620 0           while ($string !~ /\G \z/oxgc) {
4621 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4622 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4623 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4624 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4625             }
4626 0           die __FILE__, ": Search pattern not terminated";
4627             }
4628             }
4629              
4630             # qq//
4631             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4632 0           my $ope = $1;
4633 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4634 0           $e_string .= e_qq($ope,$1,$3,$2);
4635             }
4636             else {
4637 0           my $e = '';
4638 0           while ($string !~ /\G \z/oxgc) {
4639 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4640 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4641 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4642 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4643 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4644 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4645             }
4646 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4647             }
4648             }
4649              
4650             # qx//
4651             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4652 0           my $ope = $1;
4653 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4654 0           $e_string .= e_qq($ope,$1,$3,$2);
4655             }
4656             else {
4657 0           my $e = '';
4658 0           while ($string !~ /\G \z/oxgc) {
4659 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4660 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4661 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4662 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4663 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4664 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4665 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4666             }
4667 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4668             }
4669             }
4670              
4671             # q//
4672             elsif ($string =~ /\G \b (q) \b /oxgc) {
4673 0           my $ope = $1;
4674 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4675 0           $e_string .= e_q($ope,$1,$3,$2);
4676             }
4677             else {
4678 0           my $e = '';
4679 0           while ($string !~ /\G \z/oxgc) {
4680 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4681 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4682 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4683 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4684 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4685 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            
4686             }
4687 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4688             }
4689             }
4690              
4691             # ''
4692 0           elsif ($string =~ /\G (?
4693              
4694             # ""
4695 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4696              
4697             # ``
4698 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4699              
4700             # <<= <=> <= < operator
4701             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
4702 0           { $e_string .= $1; }
4703              
4704             #
4705 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4706              
4707             # --- glob
4708             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4709 0           $e_string .= 'Char::Elatin7::glob("' . $1 . '")';
4710             }
4711              
4712             # << (bit shift) --- not here document
4713 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4714              
4715             # <<'HEREDOC'
4716             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4717 0           $slash = 'm//';
4718 0           my $here_quote = $1;
4719 0           my $delimiter = $2;
4720              
4721             # get here document
4722 0 0         if ($here_script eq '') {
4723 0           $here_script = CORE::substr $_, pos $_;
4724 0           $here_script =~ s/.*?\n//oxm;
4725             }
4726 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4727 0           push @heredoc, $1 . qq{\n$delimiter\n};
4728 0           push @heredoc_delimiter, $delimiter;
4729             }
4730             else {
4731 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4732             }
4733 0           $e_string .= $here_quote;
4734             }
4735              
4736             # <<\HEREDOC
4737             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4738 0           $slash = 'm//';
4739 0           my $here_quote = $1;
4740 0           my $delimiter = $2;
4741              
4742             # get here document
4743 0 0         if ($here_script eq '') {
4744 0           $here_script = CORE::substr $_, pos $_;
4745 0           $here_script =~ s/.*?\n//oxm;
4746             }
4747 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4748 0           push @heredoc, $1 . qq{\n$delimiter\n};
4749 0           push @heredoc_delimiter, $delimiter;
4750             }
4751             else {
4752 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4753             }
4754 0           $e_string .= $here_quote;
4755             }
4756              
4757             # <<"HEREDOC"
4758             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4759 0           $slash = 'm//';
4760 0           my $here_quote = $1;
4761 0           my $delimiter = $2;
4762              
4763             # get here document
4764 0 0         if ($here_script eq '') {
4765 0           $here_script = CORE::substr $_, pos $_;
4766 0           $here_script =~ s/.*?\n//oxm;
4767             }
4768 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4769 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4770 0           push @heredoc_delimiter, $delimiter;
4771             }
4772             else {
4773 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4774             }
4775 0           $e_string .= $here_quote;
4776             }
4777              
4778             # <
4779             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4780 0           $slash = 'm//';
4781 0           my $here_quote = $1;
4782 0           my $delimiter = $2;
4783              
4784             # get here document
4785 0 0         if ($here_script eq '') {
4786 0           $here_script = CORE::substr $_, pos $_;
4787 0           $here_script =~ s/.*?\n//oxm;
4788             }
4789 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4790 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4791 0           push @heredoc_delimiter, $delimiter;
4792             }
4793             else {
4794 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4795             }
4796 0           $e_string .= $here_quote;
4797             }
4798              
4799             # <<`HEREDOC`
4800             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4801 0           $slash = 'm//';
4802 0           my $here_quote = $1;
4803 0           my $delimiter = $2;
4804              
4805             # get here document
4806 0 0         if ($here_script eq '') {
4807 0           $here_script = CORE::substr $_, pos $_;
4808 0           $here_script =~ s/.*?\n//oxm;
4809             }
4810 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4811 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4812 0           push @heredoc_delimiter, $delimiter;
4813             }
4814             else {
4815 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4816             }
4817 0           $e_string .= $here_quote;
4818             }
4819              
4820             # any operator before div
4821             elsif ($string =~ /\G (
4822             -- | \+\+ |
4823             [\)\}\]]
4824              
4825 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4826              
4827             # yada-yada or triple-dot operator
4828             elsif ($string =~ /\G (
4829             \.\.\.
4830              
4831 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4832              
4833             # any operator before m//
4834             elsif ($string =~ /\G (
4835              
4836             !~~ | !~ | != | ! |
4837             %= | % |
4838             &&= | && | &= | & |
4839             -= | -> | - |
4840             :\s*= |
4841             : |
4842             <<= | <=> | <= | < |
4843             == | => | =~ | = |
4844             >>= | >> | >= | > |
4845             \*\*= | \*\* | \*= | \* |
4846             \+= | \+ |
4847             \.\. | \.= | \. |
4848             \/\/= | \/\/ |
4849             \/= | \/ |
4850             \? |
4851             \\ |
4852             \^= | \^ |
4853             \b x= |
4854             \|\|= | \|\| | \|= | \| |
4855             ~~ | ~ |
4856             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4857             \b(?: print )\b |
4858              
4859             [,;\(\{\[]
4860              
4861 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4862              
4863             # other any character
4864 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4865              
4866             # system error
4867             else {
4868 0           die __FILE__, ": Oops, this shouldn't happen!";
4869             }
4870             }
4871              
4872 0           return $e_string;
4873             }
4874              
4875             #
4876             # character class
4877             #
4878             sub character_class {
4879 0     0 0   my($char,$modifier) = @_;
4880              
4881 0 0         if ($char eq '.') {
4882 0 0         if ($modifier =~ /s/) {
4883 0           return '${Char::Elatin7::dot_s}';
4884             }
4885             else {
4886 0           return '${Char::Elatin7::dot}';
4887             }
4888             }
4889             else {
4890 0           return Char::Elatin7::classic_character_class($char);
4891             }
4892             }
4893              
4894             #
4895             # escape capture ($1, $2, $3, ...)
4896             #
4897             sub e_capture {
4898              
4899 0     0 0   return join '', '${', $_[0], '}';
4900             }
4901              
4902             #
4903             # escape transliteration (tr/// or y///)
4904             #
4905             sub e_tr {
4906 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4907 0           my $e_tr = '';
4908 0   0       $modifier ||= '';
4909              
4910 0           $slash = 'div';
4911              
4912             # quote character class 1
4913 0           $charclass = q_tr($charclass);
4914              
4915             # quote character class 2
4916 0           $charclass2 = q_tr($charclass2);
4917              
4918             # /b /B modifier
4919 0 0         if ($modifier =~ tr/bB//d) {
4920 0 0         if ($variable eq '') {
4921 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4922             }
4923             else {
4924 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4925             }
4926             }
4927             else {
4928 0 0         if ($variable eq '') {
4929 0           $e_tr = qq{Char::Elatin7::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4930             }
4931             else {
4932 0           $e_tr = qq{Char::Elatin7::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4933             }
4934             }
4935              
4936             # clear tr/// variable
4937 0           $tr_variable = '';
4938 0           $bind_operator = '';
4939              
4940 0           return $e_tr;
4941             }
4942              
4943             #
4944             # quote for escape transliteration (tr/// or y///)
4945             #
4946             sub q_tr {
4947 0     0 0   my($charclass) = @_;
4948              
4949             # quote character class
4950 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4951 0           return e_q('', "'", "'", $charclass); # --> q' '
4952             }
4953             elsif ($charclass !~ /\//oxms) {
4954 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4955             }
4956             elsif ($charclass !~ /\#/oxms) {
4957 0           return e_q('q', '#', '#', $charclass); # --> q# #
4958             }
4959             elsif ($charclass !~ /[\<\>]/oxms) {
4960 0           return e_q('q', '<', '>', $charclass); # --> q< >
4961             }
4962             elsif ($charclass !~ /[\(\)]/oxms) {
4963 0           return e_q('q', '(', ')', $charclass); # --> q( )
4964             }
4965             elsif ($charclass !~ /[\{\}]/oxms) {
4966 0           return e_q('q', '{', '}', $charclass); # --> q{ }
4967             }
4968             else {
4969 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4970 0 0         if ($charclass !~ /\Q$char\E/xms) {
4971 0           return e_q('q', $char, $char, $charclass);
4972             }
4973             }
4974             }
4975              
4976 0           return e_q('q', '{', '}', $charclass);
4977             }
4978              
4979             #
4980             # escape q string (q//, '')
4981             #
4982             sub e_q {
4983 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4984              
4985 0           $slash = 'div';
4986              
4987 0           return join '', $ope, $delimiter, $string, $end_delimiter;
4988             }
4989              
4990             #
4991             # escape qq string (qq//, "", qx//, ``)
4992             #
4993             sub e_qq {
4994 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4995              
4996 0           $slash = 'div';
4997              
4998 0           my $left_e = 0;
4999 0           my $right_e = 0;
5000 0           my @char = $string =~ /\G(
5001             \\o\{ [0-7]+ \} |
5002             \\x\{ [0-9A-Fa-f]+ \} |
5003             \\N\{ [^0-9\}][^\}]* \} |
5004             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5005             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5006             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5007             \$ \s* \d+ |
5008             \$ \s* \{ \s* \d+ \s* \} |
5009             \$ \$ (?![\w\{]) |
5010             \$ \s* \$ \s* $qq_variable |
5011             \\?(?:$q_char)
5012             )/oxmsg;
5013              
5014 0           for (my $i=0; $i <= $#char; $i++) {
5015              
5016             # "\L\u" --> "\u\L"
5017 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5018 0           @char[$i,$i+1] = @char[$i+1,$i];
5019             }
5020              
5021             # "\U\l" --> "\l\U"
5022             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5023 0           @char[$i,$i+1] = @char[$i+1,$i];
5024             }
5025              
5026             # octal escape sequence
5027             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5028 0           $char[$i] = Char::Elatin7::octchr($1);
5029             }
5030              
5031             # hexadecimal escape sequence
5032             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5033 0           $char[$i] = Char::Elatin7::hexchr($1);
5034             }
5035              
5036             # \N{CHARNAME} --> N{CHARNAME}
5037             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5038 0           $char[$i] = $1;
5039             }
5040              
5041 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          
5042             }
5043              
5044             # \F
5045             #
5046             # P.69 Table 2-6. Translation escapes
5047             # in Chapter 2: Bits and Pieces
5048             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5049             # (and so on)
5050              
5051             # \u \l \U \L \F \Q \E
5052 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5053 0 0         if ($right_e < $left_e) {
5054 0           $char[$i] = '\\' . $char[$i];
5055             }
5056             }
5057             elsif ($char[$i] eq '\u') {
5058              
5059             # "STRING @{[ LIST EXPR ]} MORE STRING"
5060              
5061             # P.257 Other Tricks You Can Do with Hard References
5062             # in Chapter 8: References
5063             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5064              
5065             # P.353 Other Tricks You Can Do with Hard References
5066             # in Chapter 8: References
5067             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5068              
5069             # (and so on)
5070              
5071 0           $char[$i] = '@{[Char::Elatin7::ucfirst qq<';
5072 0           $left_e++;
5073             }
5074             elsif ($char[$i] eq '\l') {
5075 0           $char[$i] = '@{[Char::Elatin7::lcfirst qq<';
5076 0           $left_e++;
5077             }
5078             elsif ($char[$i] eq '\U') {
5079 0           $char[$i] = '@{[Char::Elatin7::uc qq<';
5080 0           $left_e++;
5081             }
5082             elsif ($char[$i] eq '\L') {
5083 0           $char[$i] = '@{[Char::Elatin7::lc qq<';
5084 0           $left_e++;
5085             }
5086             elsif ($char[$i] eq '\F') {
5087 0           $char[$i] = '@{[Char::Elatin7::fc qq<';
5088 0           $left_e++;
5089             }
5090             elsif ($char[$i] eq '\Q') {
5091 0           $char[$i] = '@{[CORE::quotemeta qq<';
5092 0           $left_e++;
5093             }
5094             elsif ($char[$i] eq '\E') {
5095 0 0         if ($right_e < $left_e) {
5096 0           $char[$i] = '>]}';
5097 0           $right_e++;
5098             }
5099             else {
5100 0           $char[$i] = '';
5101             }
5102             }
5103             elsif ($char[$i] eq '\Q') {
5104 0           while (1) {
5105 0 0         if (++$i > $#char) {
5106 0           last;
5107             }
5108 0 0         if ($char[$i] eq '\E') {
5109 0           last;
5110             }
5111             }
5112             }
5113             elsif ($char[$i] eq '\E') {
5114             }
5115              
5116             # $0 --> $0
5117             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5118             }
5119             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5120             }
5121              
5122             # $$ --> $$
5123             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5124             }
5125              
5126             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5127             # $1, $2, $3 --> $1, $2, $3 otherwise
5128             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5129 0           $char[$i] = e_capture($1);
5130             }
5131             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5132 0           $char[$i] = e_capture($1);
5133             }
5134              
5135             # $$foo[ ... ] --> $ $foo->[ ... ]
5136             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5137 0           $char[$i] = e_capture($1.'->'.$2);
5138             }
5139              
5140             # $$foo{ ... } --> $ $foo->{ ... }
5141             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5142 0           $char[$i] = e_capture($1.'->'.$2);
5143             }
5144              
5145             # $$foo
5146             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5147 0           $char[$i] = e_capture($1);
5148             }
5149              
5150             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin7::PREMATCH()
5151             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5152 0           $char[$i] = '@{[Char::Elatin7::PREMATCH()]}';
5153             }
5154              
5155             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin7::MATCH()
5156             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5157 0           $char[$i] = '@{[Char::Elatin7::MATCH()]}';
5158             }
5159              
5160             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin7::POSTMATCH()
5161             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5162 0           $char[$i] = '@{[Char::Elatin7::POSTMATCH()]}';
5163             }
5164              
5165             # ${ foo } --> ${ foo }
5166             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5167             }
5168              
5169             # ${ ... }
5170             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5171 0           $char[$i] = e_capture($1);
5172             }
5173             }
5174              
5175             # return string
5176 0 0         if ($left_e > $right_e) {
5177 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5178             }
5179 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5180             }
5181              
5182             #
5183             # escape qw string (qw//)
5184             #
5185             sub e_qw {
5186 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5187              
5188 0           $slash = 'div';
5189              
5190             # choice again delimiter
5191 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5192 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5193 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5194             }
5195             elsif (not $octet{')'}) {
5196 0           return join '', $ope, '(', $string, ')';
5197             }
5198             elsif (not $octet{'}'}) {
5199 0           return join '', $ope, '{', $string, '}';
5200             }
5201             elsif (not $octet{']'}) {
5202 0           return join '', $ope, '[', $string, ']';
5203             }
5204             elsif (not $octet{'>'}) {
5205 0           return join '', $ope, '<', $string, '>';
5206             }
5207             else {
5208 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5209 0 0         if (not $octet{$char}) {
5210 0           return join '', $ope, $char, $string, $char;
5211             }
5212             }
5213             }
5214              
5215             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5216 0           my @string = CORE::split(/\s+/, $string);
5217 0           for my $string (@string) {
5218 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5219 0           for my $octet (@octet) {
5220 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5221 0           $octet = '\\' . $1;
5222             }
5223             }
5224 0           $string = join '', @octet;
5225             }
5226 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5227             }
5228              
5229             #
5230             # escape here document (<<"HEREDOC", <
5231             #
5232             sub e_heredoc {
5233 0     0 0   my($string) = @_;
5234              
5235 0           $slash = 'm//';
5236              
5237 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5238              
5239 0           my $left_e = 0;
5240 0           my $right_e = 0;
5241 0           my @char = $string =~ /\G(
5242             \\o\{ [0-7]+ \} |
5243             \\x\{ [0-9A-Fa-f]+ \} |
5244             \\N\{ [^0-9\}][^\}]* \} |
5245             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5246             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5247             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5248             \$ \s* \d+ |
5249             \$ \s* \{ \s* \d+ \s* \} |
5250             \$ \$ (?![\w\{]) |
5251             \$ \s* \$ \s* $qq_variable |
5252             \\?(?:$q_char)
5253             )/oxmsg;
5254              
5255 0           for (my $i=0; $i <= $#char; $i++) {
5256              
5257             # "\L\u" --> "\u\L"
5258 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5259 0           @char[$i,$i+1] = @char[$i+1,$i];
5260             }
5261              
5262             # "\U\l" --> "\l\U"
5263             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5264 0           @char[$i,$i+1] = @char[$i+1,$i];
5265             }
5266              
5267             # octal escape sequence
5268             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5269 0           $char[$i] = Char::Elatin7::octchr($1);
5270             }
5271              
5272             # hexadecimal escape sequence
5273             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5274 0           $char[$i] = Char::Elatin7::hexchr($1);
5275             }
5276              
5277             # \N{CHARNAME} --> N{CHARNAME}
5278             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5279 0           $char[$i] = $1;
5280             }
5281              
5282 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          
5283             }
5284              
5285             # \u \l \U \L \F \Q \E
5286 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5287 0 0         if ($right_e < $left_e) {
5288 0           $char[$i] = '\\' . $char[$i];
5289             }
5290             }
5291             elsif ($char[$i] eq '\u') {
5292 0           $char[$i] = '@{[Char::Elatin7::ucfirst qq<';
5293 0           $left_e++;
5294             }
5295             elsif ($char[$i] eq '\l') {
5296 0           $char[$i] = '@{[Char::Elatin7::lcfirst qq<';
5297 0           $left_e++;
5298             }
5299             elsif ($char[$i] eq '\U') {
5300 0           $char[$i] = '@{[Char::Elatin7::uc qq<';
5301 0           $left_e++;
5302             }
5303             elsif ($char[$i] eq '\L') {
5304 0           $char[$i] = '@{[Char::Elatin7::lc qq<';
5305 0           $left_e++;
5306             }
5307             elsif ($char[$i] eq '\F') {
5308 0           $char[$i] = '@{[Char::Elatin7::fc qq<';
5309 0           $left_e++;
5310             }
5311             elsif ($char[$i] eq '\Q') {
5312 0           $char[$i] = '@{[CORE::quotemeta qq<';
5313 0           $left_e++;
5314             }
5315             elsif ($char[$i] eq '\E') {
5316 0 0         if ($right_e < $left_e) {
5317 0           $char[$i] = '>]}';
5318 0           $right_e++;
5319             }
5320             else {
5321 0           $char[$i] = '';
5322             }
5323             }
5324             elsif ($char[$i] eq '\Q') {
5325 0           while (1) {
5326 0 0         if (++$i > $#char) {
5327 0           last;
5328             }
5329 0 0         if ($char[$i] eq '\E') {
5330 0           last;
5331             }
5332             }
5333             }
5334             elsif ($char[$i] eq '\E') {
5335             }
5336              
5337             # $0 --> $0
5338             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5339             }
5340             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5341             }
5342              
5343             # $$ --> $$
5344             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5345             }
5346              
5347             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5348             # $1, $2, $3 --> $1, $2, $3 otherwise
5349             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5350 0           $char[$i] = e_capture($1);
5351             }
5352             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5353 0           $char[$i] = e_capture($1);
5354             }
5355              
5356             # $$foo[ ... ] --> $ $foo->[ ... ]
5357             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5358 0           $char[$i] = e_capture($1.'->'.$2);
5359             }
5360              
5361             # $$foo{ ... } --> $ $foo->{ ... }
5362             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5363 0           $char[$i] = e_capture($1.'->'.$2);
5364             }
5365              
5366             # $$foo
5367             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5368 0           $char[$i] = e_capture($1);
5369             }
5370              
5371             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin7::PREMATCH()
5372             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5373 0           $char[$i] = '@{[Char::Elatin7::PREMATCH()]}';
5374             }
5375              
5376             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin7::MATCH()
5377             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5378 0           $char[$i] = '@{[Char::Elatin7::MATCH()]}';
5379             }
5380              
5381             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin7::POSTMATCH()
5382             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5383 0           $char[$i] = '@{[Char::Elatin7::POSTMATCH()]}';
5384             }
5385              
5386             # ${ foo } --> ${ foo }
5387             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5388             }
5389              
5390             # ${ ... }
5391             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5392 0           $char[$i] = e_capture($1);
5393             }
5394             }
5395              
5396             # return string
5397 0 0         if ($left_e > $right_e) {
5398 0           return join '', @char, '>]}' x ($left_e - $right_e);
5399             }
5400 0           return join '', @char;
5401             }
5402              
5403             #
5404             # escape regexp (m//, qr//)
5405             #
5406             sub e_qr {
5407 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5408 0   0       $modifier ||= '';
5409              
5410 0           $modifier =~ tr/p//d;
5411 0 0         if ($modifier =~ /([adlu])/oxms) {
5412 0           my $line = 0;
5413 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5414 0 0         if ($filename ne __FILE__) {
5415 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5416 0           last;
5417             }
5418             }
5419 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5420             }
5421              
5422 0           $slash = 'div';
5423              
5424             # literal null string pattern
5425 0 0         if ($string eq '') {
    0          
5426 0           $modifier =~ tr/bB//d;
5427 0           $modifier =~ tr/i//d;
5428 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5429             }
5430              
5431             # /b /B modifier
5432             elsif ($modifier =~ tr/bB//d) {
5433              
5434             # choice again delimiter
5435 0 0         if ($delimiter =~ / [\@:] /oxms) {
5436 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5437 0           my %octet = map {$_ => 1} @char;
  0            
5438 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5439 0           $delimiter = '(';
5440 0           $end_delimiter = ')';
5441             }
5442             elsif (not $octet{'}'}) {
5443 0           $delimiter = '{';
5444 0           $end_delimiter = '}';
5445             }
5446             elsif (not $octet{']'}) {
5447 0           $delimiter = '[';
5448 0           $end_delimiter = ']';
5449             }
5450             elsif (not $octet{'>'}) {
5451 0           $delimiter = '<';
5452 0           $end_delimiter = '>';
5453             }
5454             else {
5455 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5456 0 0         if (not $octet{$char}) {
5457 0           $delimiter = $char;
5458 0           $end_delimiter = $char;
5459 0           last;
5460             }
5461             }
5462             }
5463             }
5464              
5465 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5466 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5467             }
5468             else {
5469 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5470             }
5471             }
5472              
5473 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5474 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5475              
5476             # split regexp
5477 0           my @char = $string =~ /\G(
5478             \\o\{ [0-7]+ \} |
5479             \\ [0-7]{2,3} |
5480             \\x\{ [0-9A-Fa-f]+ \} |
5481             \\x [0-9A-Fa-f]{1,2} |
5482             \\c [\x40-\x5F] |
5483             \\N\{ [^0-9\}][^\}]* \} |
5484             \\p\{ [^0-9\}][^\}]* \} |
5485             \\P\{ [^0-9\}][^\}]* \} |
5486             \\ (?:$q_char) |
5487             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5488             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5489             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5490             [\$\@] $qq_variable |
5491             \$ \s* \d+ |
5492             \$ \s* \{ \s* \d+ \s* \} |
5493             \$ \$ (?![\w\{]) |
5494             \$ \s* \$ \s* $qq_variable |
5495             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5496             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5497             \[\^ |
5498             \(\? |
5499             (?:$q_char)
5500             )/oxmsg;
5501              
5502             # choice again delimiter
5503 0 0         if ($delimiter =~ / [\@:] /oxms) {
5504 0           my %octet = map {$_ => 1} @char;
  0            
5505 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5506 0           $delimiter = '(';
5507 0           $end_delimiter = ')';
5508             }
5509             elsif (not $octet{'}'}) {
5510 0           $delimiter = '{';
5511 0           $end_delimiter = '}';
5512             }
5513             elsif (not $octet{']'}) {
5514 0           $delimiter = '[';
5515 0           $end_delimiter = ']';
5516             }
5517             elsif (not $octet{'>'}) {
5518 0           $delimiter = '<';
5519 0           $end_delimiter = '>';
5520             }
5521             else {
5522 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5523 0 0         if (not $octet{$char}) {
5524 0           $delimiter = $char;
5525 0           $end_delimiter = $char;
5526 0           last;
5527             }
5528             }
5529             }
5530             }
5531              
5532 0           my $left_e = 0;
5533 0           my $right_e = 0;
5534 0           for (my $i=0; $i <= $#char; $i++) {
5535              
5536             # "\L\u" --> "\u\L"
5537 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
5538 0           @char[$i,$i+1] = @char[$i+1,$i];
5539             }
5540              
5541             # "\U\l" --> "\l\U"
5542             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5543 0           @char[$i,$i+1] = @char[$i+1,$i];
5544             }
5545              
5546             # octal escape sequence
5547             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5548 0           $char[$i] = Char::Elatin7::octchr($1);
5549             }
5550              
5551             # hexadecimal escape sequence
5552             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5553 0           $char[$i] = Char::Elatin7::hexchr($1);
5554             }
5555              
5556             # \N{CHARNAME} --> N\{CHARNAME}
5557             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5558 0           $char[$i] = $1 . '\\' . $2;
5559             }
5560              
5561             # \p{PROPERTY} --> p\{PROPERTY}
5562             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5563 0           $char[$i] = $1 . '\\' . $2;
5564             }
5565              
5566             # \P{PROPERTY} --> P\{PROPERTY}
5567             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5568 0           $char[$i] = $1 . '\\' . $2;
5569             }
5570              
5571             # \p, \P, \X --> p, P, X
5572             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5573 0           $char[$i] = $1;
5574             }
5575              
5576 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          
5577             }
5578              
5579             # join separated multiple-octet
5580 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5581 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        
5582 0           $char[$i] .= join '', splice @char, $i+1, 3;
5583             }
5584             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)) {
5585 0           $char[$i] .= join '', splice @char, $i+1, 2;
5586             }
5587             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)) {
5588 0           $char[$i] .= join '', splice @char, $i+1, 1;
5589             }
5590             }
5591              
5592             # open character class [...]
5593             elsif ($char[$i] eq '[') {
5594 0           my $left = $i;
5595              
5596             # [] make die "Unmatched [] in regexp ..."
5597             # (and so on)
5598              
5599 0 0         if ($char[$i+1] eq ']') {
5600 0           $i++;
5601             }
5602              
5603 0           while (1) {
5604 0 0         if (++$i > $#char) {
5605 0           die __FILE__, ": Unmatched [] in regexp";
5606             }
5607 0 0         if ($char[$i] eq ']') {
5608 0           my $right = $i;
5609              
5610             # [...]
5611 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5612 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5613             }
5614             else {
5615 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
5616             }
5617              
5618 0           $i = $left;
5619 0           last;
5620             }
5621             }
5622             }
5623              
5624             # open character class [^...]
5625             elsif ($char[$i] eq '[^') {
5626 0           my $left = $i;
5627              
5628             # [^] make die "Unmatched [] in regexp ..."
5629             # (and so on)
5630              
5631 0 0         if ($char[$i+1] eq ']') {
5632 0           $i++;
5633             }
5634              
5635 0           while (1) {
5636 0 0         if (++$i > $#char) {
5637 0           die __FILE__, ": Unmatched [] in regexp";
5638             }
5639 0 0         if ($char[$i] eq ']') {
5640 0           my $right = $i;
5641              
5642             # [^...]
5643 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5644 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5645             }
5646             else {
5647 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5648             }
5649              
5650 0           $i = $left;
5651 0           last;
5652             }
5653             }
5654             }
5655              
5656             # rewrite character class or escape character
5657             elsif (my $char = character_class($char[$i],$modifier)) {
5658 0           $char[$i] = $char;
5659             }
5660              
5661             # /i modifier
5662             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin7::uc($char[$i]) ne Char::Elatin7::fc($char[$i]))) {
5663 0 0         if (CORE::length(Char::Elatin7::fc($char[$i])) == 1) {
5664 0           $char[$i] = '[' . Char::Elatin7::uc($char[$i]) . Char::Elatin7::fc($char[$i]) . ']';
5665             }
5666             else {
5667 0           $char[$i] = '(?:' . Char::Elatin7::uc($char[$i]) . '|' . Char::Elatin7::fc($char[$i]) . ')';
5668             }
5669             }
5670              
5671             # \u \l \U \L \F \Q \E
5672             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5673 0 0         if ($right_e < $left_e) {
5674 0           $char[$i] = '\\' . $char[$i];
5675             }
5676             }
5677             elsif ($char[$i] eq '\u') {
5678 0           $char[$i] = '@{[Char::Elatin7::ucfirst qq<';
5679 0           $left_e++;
5680             }
5681             elsif ($char[$i] eq '\l') {
5682 0           $char[$i] = '@{[Char::Elatin7::lcfirst qq<';
5683 0           $left_e++;
5684             }
5685             elsif ($char[$i] eq '\U') {
5686 0           $char[$i] = '@{[Char::Elatin7::uc qq<';
5687 0           $left_e++;
5688             }
5689             elsif ($char[$i] eq '\L') {
5690 0           $char[$i] = '@{[Char::Elatin7::lc qq<';
5691 0           $left_e++;
5692             }
5693             elsif ($char[$i] eq '\F') {
5694 0           $char[$i] = '@{[Char::Elatin7::fc qq<';
5695 0           $left_e++;
5696             }
5697             elsif ($char[$i] eq '\Q') {
5698 0           $char[$i] = '@{[CORE::quotemeta qq<';
5699 0           $left_e++;
5700             }
5701             elsif ($char[$i] eq '\E') {
5702 0 0         if ($right_e < $left_e) {
5703 0           $char[$i] = '>]}';
5704 0           $right_e++;
5705             }
5706             else {
5707 0           $char[$i] = '';
5708             }
5709             }
5710             elsif ($char[$i] eq '\Q') {
5711 0           while (1) {
5712 0 0         if (++$i > $#char) {
5713 0           last;
5714             }
5715 0 0         if ($char[$i] eq '\E') {
5716 0           last;
5717             }
5718             }
5719             }
5720             elsif ($char[$i] eq '\E') {
5721             }
5722              
5723             # $0 --> $0
5724             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5725 0 0         if ($ignorecase) {
5726 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5727             }
5728             }
5729             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5730 0 0         if ($ignorecase) {
5731 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5732             }
5733             }
5734              
5735             # $$ --> $$
5736             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5737             }
5738              
5739             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5740             # $1, $2, $3 --> $1, $2, $3 otherwise
5741             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5742 0           $char[$i] = e_capture($1);
5743 0 0         if ($ignorecase) {
5744 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5745             }
5746             }
5747             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5748 0           $char[$i] = e_capture($1);
5749 0 0         if ($ignorecase) {
5750 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5751             }
5752             }
5753              
5754             # $$foo[ ... ] --> $ $foo->[ ... ]
5755             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5756 0           $char[$i] = e_capture($1.'->'.$2);
5757 0 0         if ($ignorecase) {
5758 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5759             }
5760             }
5761              
5762             # $$foo{ ... } --> $ $foo->{ ... }
5763             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5764 0           $char[$i] = e_capture($1.'->'.$2);
5765 0 0         if ($ignorecase) {
5766 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5767             }
5768             }
5769              
5770             # $$foo
5771             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5772 0           $char[$i] = e_capture($1);
5773 0 0         if ($ignorecase) {
5774 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5775             }
5776             }
5777              
5778             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin7::PREMATCH()
5779             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5780 0 0         if ($ignorecase) {
5781 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::PREMATCH())]}';
5782             }
5783             else {
5784 0           $char[$i] = '@{[Char::Elatin7::PREMATCH()]}';
5785             }
5786             }
5787              
5788             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin7::MATCH()
5789             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5790 0 0         if ($ignorecase) {
5791 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::MATCH())]}';
5792             }
5793             else {
5794 0           $char[$i] = '@{[Char::Elatin7::MATCH()]}';
5795             }
5796             }
5797              
5798             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin7::POSTMATCH()
5799             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5800 0 0         if ($ignorecase) {
5801 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::POSTMATCH())]}';
5802             }
5803             else {
5804 0           $char[$i] = '@{[Char::Elatin7::POSTMATCH()]}';
5805             }
5806             }
5807              
5808             # ${ foo }
5809             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5810 0 0         if ($ignorecase) {
5811 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5812             }
5813             }
5814              
5815             # ${ ... }
5816             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5817 0           $char[$i] = e_capture($1);
5818 0 0         if ($ignorecase) {
5819 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5820             }
5821             }
5822              
5823             # $scalar or @array
5824             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5825 0           $char[$i] = e_string($char[$i]);
5826 0 0         if ($ignorecase) {
5827 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
5828             }
5829             }
5830              
5831             # quote character before ? + * {
5832             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5833 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5834             }
5835             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5836 0           my $char = $char[$i-1];
5837 0 0         if ($char[$i] eq '{') {
5838 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
5839             }
5840             else {
5841 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
5842             }
5843             }
5844             else {
5845 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5846             }
5847             }
5848             }
5849              
5850             # make regexp string
5851 0           $modifier =~ tr/i//d;
5852 0 0         if ($left_e > $right_e) {
5853 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5854 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5855             }
5856             else {
5857 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5858             }
5859             }
5860 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5861 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5862             }
5863             else {
5864 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5865             }
5866             }
5867              
5868             #
5869             # double quote stuff
5870             #
5871             sub qq_stuff {
5872 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5873              
5874             # scalar variable or array variable
5875 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5876 0           return $stuff;
5877             }
5878              
5879             # quote by delimiter
5880 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5881 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5882 0 0         next if $char eq $delimiter;
5883 0 0         next if $char eq $end_delimiter;
5884 0 0         if (not $octet{$char}) {
5885 0           return join '', 'qq', $char, $stuff, $char;
5886             }
5887             }
5888 0           return join '', 'qq', '<', $stuff, '>';
5889             }
5890              
5891             #
5892             # escape regexp (m'', qr'', and m''b, qr''b)
5893             #
5894             sub e_qr_q {
5895 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5896 0   0       $modifier ||= '';
5897              
5898 0           $modifier =~ tr/p//d;
5899 0 0         if ($modifier =~ /([adlu])/oxms) {
5900 0           my $line = 0;
5901 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5902 0 0         if ($filename ne __FILE__) {
5903 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5904 0           last;
5905             }
5906             }
5907 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5908             }
5909              
5910 0           $slash = 'div';
5911              
5912             # literal null string pattern
5913 0 0         if ($string eq '') {
    0          
5914 0           $modifier =~ tr/bB//d;
5915 0           $modifier =~ tr/i//d;
5916 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5917             }
5918              
5919             # with /b /B modifier
5920             elsif ($modifier =~ tr/bB//d) {
5921 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5922             }
5923              
5924             # without /b /B modifier
5925             else {
5926 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5927             }
5928             }
5929              
5930             #
5931             # escape regexp (m'', qr'')
5932             #
5933             sub e_qr_qt {
5934 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5935              
5936 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5937              
5938             # split regexp
5939 0           my @char = $string =~ /\G(
5940             \[\:\^ [a-z]+ \:\] |
5941             \[\: [a-z]+ \:\] |
5942             \[\^ |
5943             [\$\@\/\\] |
5944             \\? (?:$q_char)
5945             )/oxmsg;
5946              
5947             # unescape character
5948 0           for (my $i=0; $i <= $#char; $i++) {
5949 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5950             }
5951              
5952             # open character class [...]
5953 0           elsif ($char[$i] eq '[') {
5954 0           my $left = $i;
5955 0 0         if ($char[$i+1] eq ']') {
5956 0           $i++;
5957             }
5958 0           while (1) {
5959 0 0         if (++$i > $#char) {
5960 0           die __FILE__, ": Unmatched [] in regexp";
5961             }
5962 0 0         if ($char[$i] eq ']') {
5963 0           my $right = $i;
5964              
5965             # [...]
5966 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
5967              
5968 0           $i = $left;
5969 0           last;
5970             }
5971             }
5972             }
5973              
5974             # open character class [^...]
5975             elsif ($char[$i] eq '[^') {
5976 0           my $left = $i;
5977 0 0         if ($char[$i+1] eq ']') {
5978 0           $i++;
5979             }
5980 0           while (1) {
5981 0 0         if (++$i > $#char) {
5982 0           die __FILE__, ": Unmatched [] in regexp";
5983             }
5984 0 0         if ($char[$i] eq ']') {
5985 0           my $right = $i;
5986              
5987             # [^...]
5988 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5989              
5990 0           $i = $left;
5991 0           last;
5992             }
5993             }
5994             }
5995              
5996             # escape $ @ / and \
5997             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5998 0           $char[$i] = '\\' . $char[$i];
5999             }
6000              
6001             # rewrite character class or escape character
6002             elsif (my $char = character_class($char[$i],$modifier)) {
6003 0           $char[$i] = $char;
6004             }
6005              
6006             # /i modifier
6007             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin7::uc($char[$i]) ne Char::Elatin7::fc($char[$i]))) {
6008 0 0         if (CORE::length(Char::Elatin7::fc($char[$i])) == 1) {
6009 0           $char[$i] = '[' . Char::Elatin7::uc($char[$i]) . Char::Elatin7::fc($char[$i]) . ']';
6010             }
6011             else {
6012 0           $char[$i] = '(?:' . Char::Elatin7::uc($char[$i]) . '|' . Char::Elatin7::fc($char[$i]) . ')';
6013             }
6014             }
6015              
6016             # quote character before ? + * {
6017             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6018 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6019             }
6020             else {
6021 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6022             }
6023             }
6024             }
6025              
6026 0           $delimiter = '/';
6027 0           $end_delimiter = '/';
6028              
6029 0           $modifier =~ tr/i//d;
6030 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6031             }
6032              
6033             #
6034             # escape regexp (m''b, qr''b)
6035             #
6036             sub e_qr_qb {
6037 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6038              
6039             # split regexp
6040 0           my @char = $string =~ /\G(
6041             \\\\ |
6042             [\$\@\/\\] |
6043             [\x00-\xFF]
6044             )/oxmsg;
6045              
6046             # unescape character
6047 0           for (my $i=0; $i <= $#char; $i++) {
6048 0 0         if (0) {
    0          
6049             }
6050              
6051             # remain \\
6052 0           elsif ($char[$i] eq '\\\\') {
6053             }
6054              
6055             # escape $ @ / and \
6056             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6057 0           $char[$i] = '\\' . $char[$i];
6058             }
6059             }
6060              
6061 0           $delimiter = '/';
6062 0           $end_delimiter = '/';
6063 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6064             }
6065              
6066             #
6067             # escape regexp (s/here//)
6068             #
6069             sub e_s1 {
6070 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6071 0   0       $modifier ||= '';
6072              
6073 0           $modifier =~ tr/p//d;
6074 0 0         if ($modifier =~ /([adlu])/oxms) {
6075 0           my $line = 0;
6076 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6077 0 0         if ($filename ne __FILE__) {
6078 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6079 0           last;
6080             }
6081             }
6082 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6083             }
6084              
6085 0           $slash = 'div';
6086              
6087             # literal null string pattern
6088 0 0         if ($string eq '') {
    0          
6089 0           $modifier =~ tr/bB//d;
6090 0           $modifier =~ tr/i//d;
6091 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6092             }
6093              
6094             # /b /B modifier
6095             elsif ($modifier =~ tr/bB//d) {
6096              
6097             # choice again delimiter
6098 0 0         if ($delimiter =~ / [\@:] /oxms) {
6099 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
6100 0           my %octet = map {$_ => 1} @char;
  0            
6101 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6102 0           $delimiter = '(';
6103 0           $end_delimiter = ')';
6104             }
6105             elsif (not $octet{'}'}) {
6106 0           $delimiter = '{';
6107 0           $end_delimiter = '}';
6108             }
6109             elsif (not $octet{']'}) {
6110 0           $delimiter = '[';
6111 0           $end_delimiter = ']';
6112             }
6113             elsif (not $octet{'>'}) {
6114 0           $delimiter = '<';
6115 0           $end_delimiter = '>';
6116             }
6117             else {
6118 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6119 0 0         if (not $octet{$char}) {
6120 0           $delimiter = $char;
6121 0           $end_delimiter = $char;
6122 0           last;
6123             }
6124             }
6125             }
6126             }
6127              
6128 0           my $prematch = '';
6129 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6130             }
6131              
6132 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6133 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6134              
6135             # split regexp
6136 0           my @char = $string =~ /\G(
6137             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
6138             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
6139             \\g \s* [1-9][0-9]* |
6140             \\o\{ [0-7]+ \} |
6141             \\ [1-9][0-9]* |
6142             \\ [0-7]{2,3} |
6143             \\x\{ [0-9A-Fa-f]+ \} |
6144             \\x [0-9A-Fa-f]{1,2} |
6145             \\c [\x40-\x5F] |
6146             \\N\{ [^0-9\}][^\}]* \} |
6147             \\p\{ [^0-9\}][^\}]* \} |
6148             \\P\{ [^0-9\}][^\}]* \} |
6149             \\ (?:$q_char) |
6150             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6151             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6152             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6153             [\$\@] $qq_variable |
6154             \$ \s* \d+ |
6155             \$ \s* \{ \s* \d+ \s* \} |
6156             \$ \$ (?![\w\{]) |
6157             \$ \s* \$ \s* $qq_variable |
6158             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6159             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6160             \[\^ |
6161             \(\? |
6162             (?:$q_char)
6163             )/oxmsg;
6164              
6165             # choice again delimiter
6166 0 0         if ($delimiter =~ / [\@:] /oxms) {
6167 0           my %octet = map {$_ => 1} @char;
  0            
6168 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6169 0           $delimiter = '(';
6170 0           $end_delimiter = ')';
6171             }
6172             elsif (not $octet{'}'}) {
6173 0           $delimiter = '{';
6174 0           $end_delimiter = '}';
6175             }
6176             elsif (not $octet{']'}) {
6177 0           $delimiter = '[';
6178 0           $end_delimiter = ']';
6179             }
6180             elsif (not $octet{'>'}) {
6181 0           $delimiter = '<';
6182 0           $end_delimiter = '>';
6183             }
6184             else {
6185 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6186 0 0         if (not $octet{$char}) {
6187 0           $delimiter = $char;
6188 0           $end_delimiter = $char;
6189 0           last;
6190             }
6191             }
6192             }
6193             }
6194              
6195             # count '('
6196 0           my $parens = grep { $_ eq '(' } @char;
  0            
6197              
6198 0           my $left_e = 0;
6199 0           my $right_e = 0;
6200 0           for (my $i=0; $i <= $#char; $i++) {
6201              
6202             # "\L\u" --> "\u\L"
6203 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6204 0           @char[$i,$i+1] = @char[$i+1,$i];
6205             }
6206              
6207             # "\U\l" --> "\l\U"
6208             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6209 0           @char[$i,$i+1] = @char[$i+1,$i];
6210             }
6211              
6212             # octal escape sequence
6213             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6214 0           $char[$i] = Char::Elatin7::octchr($1);
6215             }
6216              
6217             # hexadecimal escape sequence
6218             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6219 0           $char[$i] = Char::Elatin7::hexchr($1);
6220             }
6221              
6222             # \N{CHARNAME} --> N\{CHARNAME}
6223             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6224 0           $char[$i] = $1 . '\\' . $2;
6225             }
6226              
6227             # \p{PROPERTY} --> p\{PROPERTY}
6228             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6229 0           $char[$i] = $1 . '\\' . $2;
6230             }
6231              
6232             # \P{PROPERTY} --> P\{PROPERTY}
6233             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6234 0           $char[$i] = $1 . '\\' . $2;
6235             }
6236              
6237             # \p, \P, \X --> p, P, X
6238             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6239 0           $char[$i] = $1;
6240             }
6241              
6242 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          
6243             }
6244              
6245             # join separated multiple-octet
6246 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6247 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        
6248 0           $char[$i] .= join '', splice @char, $i+1, 3;
6249             }
6250             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)) {
6251 0           $char[$i] .= join '', splice @char, $i+1, 2;
6252             }
6253             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)) {
6254 0           $char[$i] .= join '', splice @char, $i+1, 1;
6255             }
6256             }
6257              
6258             # open character class [...]
6259             elsif ($char[$i] eq '[') {
6260 0           my $left = $i;
6261 0 0         if ($char[$i+1] eq ']') {
6262 0           $i++;
6263             }
6264 0           while (1) {
6265 0 0         if (++$i > $#char) {
6266 0           die __FILE__, ": Unmatched [] in regexp";
6267             }
6268 0 0         if ($char[$i] eq ']') {
6269 0           my $right = $i;
6270              
6271             # [...]
6272 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6273 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6274             }
6275             else {
6276 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6277             }
6278              
6279 0           $i = $left;
6280 0           last;
6281             }
6282             }
6283             }
6284              
6285             # open character class [^...]
6286             elsif ($char[$i] eq '[^') {
6287 0           my $left = $i;
6288 0 0         if ($char[$i+1] eq ']') {
6289 0           $i++;
6290             }
6291 0           while (1) {
6292 0 0         if (++$i > $#char) {
6293 0           die __FILE__, ": Unmatched [] in regexp";
6294             }
6295 0 0         if ($char[$i] eq ']') {
6296 0           my $right = $i;
6297              
6298             # [^...]
6299 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6300 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6301             }
6302             else {
6303 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6304             }
6305              
6306 0           $i = $left;
6307 0           last;
6308             }
6309             }
6310             }
6311              
6312             # rewrite character class or escape character
6313             elsif (my $char = character_class($char[$i],$modifier)) {
6314 0           $char[$i] = $char;
6315             }
6316              
6317             # /i modifier
6318             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin7::uc($char[$i]) ne Char::Elatin7::fc($char[$i]))) {
6319 0 0         if (CORE::length(Char::Elatin7::fc($char[$i])) == 1) {
6320 0           $char[$i] = '[' . Char::Elatin7::uc($char[$i]) . Char::Elatin7::fc($char[$i]) . ']';
6321             }
6322             else {
6323 0           $char[$i] = '(?:' . Char::Elatin7::uc($char[$i]) . '|' . Char::Elatin7::fc($char[$i]) . ')';
6324             }
6325             }
6326              
6327             # \u \l \U \L \F \Q \E
6328             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6329 0 0         if ($right_e < $left_e) {
6330 0           $char[$i] = '\\' . $char[$i];
6331             }
6332             }
6333             elsif ($char[$i] eq '\u') {
6334 0           $char[$i] = '@{[Char::Elatin7::ucfirst qq<';
6335 0           $left_e++;
6336             }
6337             elsif ($char[$i] eq '\l') {
6338 0           $char[$i] = '@{[Char::Elatin7::lcfirst qq<';
6339 0           $left_e++;
6340             }
6341             elsif ($char[$i] eq '\U') {
6342 0           $char[$i] = '@{[Char::Elatin7::uc qq<';
6343 0           $left_e++;
6344             }
6345             elsif ($char[$i] eq '\L') {
6346 0           $char[$i] = '@{[Char::Elatin7::lc qq<';
6347 0           $left_e++;
6348             }
6349             elsif ($char[$i] eq '\F') {
6350 0           $char[$i] = '@{[Char::Elatin7::fc qq<';
6351 0           $left_e++;
6352             }
6353             elsif ($char[$i] eq '\Q') {
6354 0           $char[$i] = '@{[CORE::quotemeta qq<';
6355 0           $left_e++;
6356             }
6357             elsif ($char[$i] eq '\E') {
6358 0 0         if ($right_e < $left_e) {
6359 0           $char[$i] = '>]}';
6360 0           $right_e++;
6361             }
6362             else {
6363 0           $char[$i] = '';
6364             }
6365             }
6366             elsif ($char[$i] eq '\Q') {
6367 0           while (1) {
6368 0 0         if (++$i > $#char) {
6369 0           last;
6370             }
6371 0 0         if ($char[$i] eq '\E') {
6372 0           last;
6373             }
6374             }
6375             }
6376             elsif ($char[$i] eq '\E') {
6377             }
6378              
6379             # \0 --> \0
6380             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
6381             }
6382              
6383             # \g{N}, \g{-N}
6384              
6385             # P.108 Using Simple Patterns
6386             # in Chapter 7: In the World of Regular Expressions
6387             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6388              
6389             # P.221 Capturing
6390             # in Chapter 5: Pattern Matching
6391             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6392              
6393             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6394             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6395             }
6396              
6397             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6398             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6399             }
6400              
6401             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6402             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
6403             }
6404              
6405             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6406             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
6407             }
6408              
6409             # $0 --> $0
6410             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6411 0 0         if ($ignorecase) {
6412 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6413             }
6414             }
6415             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
6416 0 0         if ($ignorecase) {
6417 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6418             }
6419             }
6420              
6421             # $$ --> $$
6422             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6423             }
6424              
6425             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6426             # $1, $2, $3 --> $1, $2, $3 otherwise
6427             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
6428 0           $char[$i] = e_capture($1);
6429 0 0         if ($ignorecase) {
6430 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6431             }
6432             }
6433             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6434 0           $char[$i] = e_capture($1);
6435 0 0         if ($ignorecase) {
6436 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6437             }
6438             }
6439              
6440             # $$foo[ ... ] --> $ $foo->[ ... ]
6441             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6442 0           $char[$i] = e_capture($1.'->'.$2);
6443 0 0         if ($ignorecase) {
6444 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6445             }
6446             }
6447              
6448             # $$foo{ ... } --> $ $foo->{ ... }
6449             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6450 0           $char[$i] = e_capture($1.'->'.$2);
6451 0 0         if ($ignorecase) {
6452 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6453             }
6454             }
6455              
6456             # $$foo
6457             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
6458 0           $char[$i] = e_capture($1);
6459 0 0         if ($ignorecase) {
6460 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6461             }
6462             }
6463              
6464             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin7::PREMATCH()
6465             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
6466 0 0         if ($ignorecase) {
6467 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::PREMATCH())]}';
6468             }
6469             else {
6470 0           $char[$i] = '@{[Char::Elatin7::PREMATCH()]}';
6471             }
6472             }
6473              
6474             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin7::MATCH()
6475             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
6476 0 0         if ($ignorecase) {
6477 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::MATCH())]}';
6478             }
6479             else {
6480 0           $char[$i] = '@{[Char::Elatin7::MATCH()]}';
6481             }
6482             }
6483              
6484             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin7::POSTMATCH()
6485             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
6486 0 0         if ($ignorecase) {
6487 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::POSTMATCH())]}';
6488             }
6489             else {
6490 0           $char[$i] = '@{[Char::Elatin7::POSTMATCH()]}';
6491             }
6492             }
6493              
6494             # ${ foo }
6495             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
6496 0 0         if ($ignorecase) {
6497 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6498             }
6499             }
6500              
6501             # ${ ... }
6502             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
6503 0           $char[$i] = e_capture($1);
6504 0 0         if ($ignorecase) {
6505 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6506             }
6507             }
6508              
6509             # $scalar or @array
6510             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6511 0           $char[$i] = e_string($char[$i]);
6512 0 0         if ($ignorecase) {
6513 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
6514             }
6515             }
6516              
6517             # quote character before ? + * {
6518             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6519 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6520             }
6521             else {
6522 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6523             }
6524             }
6525             }
6526              
6527             # make regexp string
6528 0           my $prematch = '';
6529 0           $modifier =~ tr/i//d;
6530 0 0         if ($left_e > $right_e) {
6531 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6532             }
6533 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6534             }
6535              
6536             #
6537             # escape regexp (s'here'' or s'here''b)
6538             #
6539             sub e_s1_q {
6540 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6541 0   0       $modifier ||= '';
6542              
6543 0           $modifier =~ tr/p//d;
6544 0 0         if ($modifier =~ /([adlu])/oxms) {
6545 0           my $line = 0;
6546 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6547 0 0         if ($filename ne __FILE__) {
6548 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6549 0           last;
6550             }
6551             }
6552 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6553             }
6554              
6555 0           $slash = 'div';
6556              
6557             # literal null string pattern
6558 0 0         if ($string eq '') {
    0          
6559 0           $modifier =~ tr/bB//d;
6560 0           $modifier =~ tr/i//d;
6561 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6562             }
6563              
6564             # with /b /B modifier
6565             elsif ($modifier =~ tr/bB//d) {
6566 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6567             }
6568              
6569             # without /b /B modifier
6570             else {
6571 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6572             }
6573             }
6574              
6575             #
6576             # escape regexp (s'here'')
6577             #
6578             sub e_s1_qt {
6579 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6580              
6581 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6582              
6583             # split regexp
6584 0           my @char = $string =~ /\G(
6585             \[\:\^ [a-z]+ \:\] |
6586             \[\: [a-z]+ \:\] |
6587             \[\^ |
6588             [\$\@\/\\] |
6589             \\? (?:$q_char)
6590             )/oxmsg;
6591              
6592             # unescape character
6593 0           for (my $i=0; $i <= $#char; $i++) {
6594 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6595             }
6596              
6597             # open character class [...]
6598 0           elsif ($char[$i] eq '[') {
6599 0           my $left = $i;
6600 0 0         if ($char[$i+1] eq ']') {
6601 0           $i++;
6602             }
6603 0           while (1) {
6604 0 0         if (++$i > $#char) {
6605 0           die __FILE__, ": Unmatched [] in regexp";
6606             }
6607 0 0         if ($char[$i] eq ']') {
6608 0           my $right = $i;
6609              
6610             # [...]
6611 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6612              
6613 0           $i = $left;
6614 0           last;
6615             }
6616             }
6617             }
6618              
6619             # open character class [^...]
6620             elsif ($char[$i] eq '[^') {
6621 0           my $left = $i;
6622 0 0         if ($char[$i+1] eq ']') {
6623 0           $i++;
6624             }
6625 0           while (1) {
6626 0 0         if (++$i > $#char) {
6627 0           die __FILE__, ": Unmatched [] in regexp";
6628             }
6629 0 0         if ($char[$i] eq ']') {
6630 0           my $right = $i;
6631              
6632             # [^...]
6633 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6634              
6635 0           $i = $left;
6636 0           last;
6637             }
6638             }
6639             }
6640              
6641             # escape $ @ / and \
6642             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6643 0           $char[$i] = '\\' . $char[$i];
6644             }
6645              
6646             # rewrite character class or escape character
6647             elsif (my $char = character_class($char[$i],$modifier)) {
6648 0           $char[$i] = $char;
6649             }
6650              
6651             # /i modifier
6652             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin7::uc($char[$i]) ne Char::Elatin7::fc($char[$i]))) {
6653 0 0         if (CORE::length(Char::Elatin7::fc($char[$i])) == 1) {
6654 0           $char[$i] = '[' . Char::Elatin7::uc($char[$i]) . Char::Elatin7::fc($char[$i]) . ']';
6655             }
6656             else {
6657 0           $char[$i] = '(?:' . Char::Elatin7::uc($char[$i]) . '|' . Char::Elatin7::fc($char[$i]) . ')';
6658             }
6659             }
6660              
6661             # quote character before ? + * {
6662             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6663 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6664             }
6665             else {
6666 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6667             }
6668             }
6669             }
6670              
6671 0           $modifier =~ tr/i//d;
6672 0           $delimiter = '/';
6673 0           $end_delimiter = '/';
6674 0           my $prematch = '';
6675 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6676             }
6677              
6678             #
6679             # escape regexp (s'here''b)
6680             #
6681             sub e_s1_qb {
6682 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6683              
6684             # split regexp
6685 0           my @char = $string =~ /\G(
6686             \\\\ |
6687             [\$\@\/\\] |
6688             [\x00-\xFF]
6689             )/oxmsg;
6690              
6691             # unescape character
6692 0           for (my $i=0; $i <= $#char; $i++) {
6693 0 0         if (0) {
    0          
6694             }
6695              
6696             # remain \\
6697 0           elsif ($char[$i] eq '\\\\') {
6698             }
6699              
6700             # escape $ @ / and \
6701             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6702 0           $char[$i] = '\\' . $char[$i];
6703             }
6704             }
6705              
6706 0           $delimiter = '/';
6707 0           $end_delimiter = '/';
6708 0           my $prematch = '';
6709 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6710             }
6711              
6712             #
6713             # escape regexp (s''here')
6714             #
6715             sub e_s2_q {
6716 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6717              
6718 0           $slash = 'div';
6719              
6720 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
6721 0           for (my $i=0; $i <= $#char; $i++) {
6722 0 0         if (0) {
    0          
6723             }
6724              
6725             # not escape \\
6726 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6727             }
6728              
6729             # escape $ @ / and \
6730             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6731 0           $char[$i] = '\\' . $char[$i];
6732             }
6733             }
6734              
6735 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6736             }
6737              
6738             #
6739             # escape regexp (s/here/and here/modifier)
6740             #
6741             sub e_sub {
6742 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6743 0   0       $modifier ||= '';
6744              
6745 0           $modifier =~ tr/p//d;
6746 0 0         if ($modifier =~ /([adlu])/oxms) {
6747 0           my $line = 0;
6748 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6749 0 0         if ($filename ne __FILE__) {
6750 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6751 0           last;
6752             }
6753             }
6754 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6755             }
6756              
6757 0 0         if ($variable eq '') {
6758 0           $variable = '$_';
6759 0           $bind_operator = ' =~ ';
6760             }
6761              
6762 0           $slash = 'div';
6763              
6764             # P.128 Start of match (or end of previous match): \G
6765             # P.130 Advanced Use of \G with Perl
6766             # in Chapter 3: Overview of Regular Expression Features and Flavors
6767             # P.312 Iterative Matching: Scalar Context, with /g
6768             # in Chapter 7: Perl
6769             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6770              
6771             # P.181 Where You Left Off: The \G Assertion
6772             # in Chapter 5: Pattern Matching
6773             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6774              
6775             # P.220 Where You Left Off: The \G Assertion
6776             # in Chapter 5: Pattern Matching
6777             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6778              
6779 0           my $e_modifier = $modifier =~ tr/e//d;
6780 0           my $r_modifier = $modifier =~ tr/r//d;
6781              
6782 0           my $my = '';
6783 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
6784 0           $my = $variable;
6785 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
6786 0           $variable =~ s/ = .+ \z//oxms;
6787             }
6788              
6789 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6790 0           $variable_basename =~ s/ \s+ \z//oxms;
6791              
6792             # quote replacement string
6793 0           my $e_replacement = '';
6794 0 0         if ($e_modifier >= 1) {
6795 0           $e_replacement = e_qq('', '', '', $replacement);
6796 0           $e_modifier--;
6797             }
6798             else {
6799 0 0         if ($delimiter2 eq "'") {
6800 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6801             }
6802             else {
6803 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6804             }
6805             }
6806              
6807 0           my $sub = '';
6808              
6809             # with /r
6810 0 0         if ($r_modifier) {
6811 0 0         if (0) {
6812             }
6813              
6814             # s///gr without multibyte anchoring
6815 0           elsif ($modifier =~ /g/oxms) {
6816 0 0         $sub = sprintf(
6817             # 1 2 3 4 5
6818             q,
6819              
6820             $variable, # 1
6821             ($delimiter1 eq "'") ? # 2
6822             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6823             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6824             $s_matched, # 3
6825             $e_replacement, # 4
6826             '$Char::Latin7::re_r=CORE::eval $Char::Latin7::re_r; ' x $e_modifier, # 5
6827             );
6828             }
6829              
6830             # s///r
6831             else {
6832              
6833 0           my $prematch = q{$`};
6834              
6835 0 0         $sub = sprintf(
6836             # 1 2 3 4 5 6 7
6837             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Char::Latin7::re_r=%s; %s"%s$Char::Latin7::re_r$'" } : %s>,
6838              
6839             $variable, # 1
6840             ($delimiter1 eq "'") ? # 2
6841             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6842             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6843             $s_matched, # 3
6844             $e_replacement, # 4
6845             '$Char::Latin7::re_r=CORE::eval $Char::Latin7::re_r; ' x $e_modifier, # 5
6846             $prematch, # 6
6847             $variable, # 7
6848             );
6849             }
6850              
6851             # $var !~ s///r doesn't make sense
6852 0 0         if ($bind_operator =~ / !~ /oxms) {
6853 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6854             }
6855             }
6856              
6857             # without /r
6858             else {
6859 0 0         if (0) {
6860             }
6861              
6862             # s///g without multibyte anchoring
6863 0           elsif ($modifier =~ /g/oxms) {
6864 0 0         $sub = sprintf(
    0          
6865             # 1 2 3 4 5 6 7 8
6866             q,
6867              
6868             $variable, # 1
6869             ($delimiter1 eq "'") ? # 2
6870             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6871             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6872             $s_matched, # 3
6873             $e_replacement, # 4
6874             '$Char::Latin7::re_r=CORE::eval $Char::Latin7::re_r; ' x $e_modifier, # 5
6875             $variable, # 6
6876             $variable, # 7
6877             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6878             );
6879             }
6880              
6881             # s///
6882             else {
6883              
6884 0           my $prematch = q{$`};
6885              
6886 0 0         $sub = sprintf(
    0          
6887              
6888             ($bind_operator =~ / =~ /oxms) ?
6889              
6890             # 1 2 3 4 5 6 7 8
6891             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Char::Latin7::re_r=%s; %s%s="%s$Char::Latin7::re_r$'"; 1 } : undef> :
6892              
6893             # 1 2 3 4 5 6 7 8
6894             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Char::Latin7::re_r=%s; %s%s="%s$Char::Latin7::re_r$'"; undef }>,
6895              
6896             $variable, # 1
6897             $bind_operator, # 2
6898             ($delimiter1 eq "'") ? # 3
6899             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6900             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6901             $s_matched, # 4
6902             $e_replacement, # 5
6903             '$Char::Latin7::re_r=CORE::eval $Char::Latin7::re_r; ' x $e_modifier, # 6
6904             $variable, # 7
6905             $prematch, # 8
6906             );
6907             }
6908             }
6909              
6910             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6911 0 0         if ($my ne '') {
6912 0           $sub = "($my, $sub)[1]";
6913             }
6914              
6915             # clear s/// variable
6916 0           $sub_variable = '';
6917 0           $bind_operator = '';
6918              
6919 0           return $sub;
6920             }
6921              
6922             #
6923             # escape regexp of split qr//
6924             #
6925             sub e_split {
6926 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6927 0   0       $modifier ||= '';
6928              
6929 0           $modifier =~ tr/p//d;
6930 0 0         if ($modifier =~ /([adlu])/oxms) {
6931 0           my $line = 0;
6932 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6933 0 0         if ($filename ne __FILE__) {
6934 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6935 0           last;
6936             }
6937             }
6938 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6939             }
6940              
6941 0           $slash = 'div';
6942              
6943             # /b /B modifier
6944 0 0         if ($modifier =~ tr/bB//d) {
6945 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6946             }
6947              
6948 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6949 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6950              
6951             # split regexp
6952 0           my @char = $string =~ /\G(
6953             \\o\{ [0-7]+ \} |
6954             \\ [0-7]{2,3} |
6955             \\x\{ [0-9A-Fa-f]+ \} |
6956             \\x [0-9A-Fa-f]{1,2} |
6957             \\c [\x40-\x5F] |
6958             \\N\{ [^0-9\}][^\}]* \} |
6959             \\p\{ [^0-9\}][^\}]* \} |
6960             \\P\{ [^0-9\}][^\}]* \} |
6961             \\ (?:$q_char) |
6962             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6963             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6964             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6965             [\$\@] $qq_variable |
6966             \$ \s* \d+ |
6967             \$ \s* \{ \s* \d+ \s* \} |
6968             \$ \$ (?![\w\{]) |
6969             \$ \s* \$ \s* $qq_variable |
6970             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6971             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6972             \[\^ |
6973             \(\? |
6974             (?:$q_char)
6975             )/oxmsg;
6976              
6977 0           my $left_e = 0;
6978 0           my $right_e = 0;
6979 0           for (my $i=0; $i <= $#char; $i++) {
6980              
6981             # "\L\u" --> "\u\L"
6982 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6983 0           @char[$i,$i+1] = @char[$i+1,$i];
6984             }
6985              
6986             # "\U\l" --> "\l\U"
6987             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6988 0           @char[$i,$i+1] = @char[$i+1,$i];
6989             }
6990              
6991             # octal escape sequence
6992             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6993 0           $char[$i] = Char::Elatin7::octchr($1);
6994             }
6995              
6996             # hexadecimal escape sequence
6997             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6998 0           $char[$i] = Char::Elatin7::hexchr($1);
6999             }
7000              
7001             # \N{CHARNAME} --> N\{CHARNAME}
7002             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7003 0           $char[$i] = $1 . '\\' . $2;
7004             }
7005              
7006             # \p{PROPERTY} --> p\{PROPERTY}
7007             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7008 0           $char[$i] = $1 . '\\' . $2;
7009             }
7010              
7011             # \P{PROPERTY} --> P\{PROPERTY}
7012             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7013 0           $char[$i] = $1 . '\\' . $2;
7014             }
7015              
7016             # \p, \P, \X --> p, P, X
7017             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7018 0           $char[$i] = $1;
7019             }
7020              
7021 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          
7022             }
7023              
7024             # join separated multiple-octet
7025 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7026 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        
7027 0           $char[$i] .= join '', splice @char, $i+1, 3;
7028             }
7029             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)) {
7030 0           $char[$i] .= join '', splice @char, $i+1, 2;
7031             }
7032             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)) {
7033 0           $char[$i] .= join '', splice @char, $i+1, 1;
7034             }
7035             }
7036              
7037             # open character class [...]
7038             elsif ($char[$i] eq '[') {
7039 0           my $left = $i;
7040 0 0         if ($char[$i+1] eq ']') {
7041 0           $i++;
7042             }
7043 0           while (1) {
7044 0 0         if (++$i > $#char) {
7045 0           die __FILE__, ": Unmatched [] in regexp";
7046             }
7047 0 0         if ($char[$i] eq ']') {
7048 0           my $right = $i;
7049              
7050             # [...]
7051 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7052 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7053             }
7054             else {
7055 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
7056             }
7057              
7058 0           $i = $left;
7059 0           last;
7060             }
7061             }
7062             }
7063              
7064             # open character class [^...]
7065             elsif ($char[$i] eq '[^') {
7066 0           my $left = $i;
7067 0 0         if ($char[$i+1] eq ']') {
7068 0           $i++;
7069             }
7070 0           while (1) {
7071 0 0         if (++$i > $#char) {
7072 0           die __FILE__, ": Unmatched [] in regexp";
7073             }
7074 0 0         if ($char[$i] eq ']') {
7075 0           my $right = $i;
7076              
7077             # [^...]
7078 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7079 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7080             }
7081             else {
7082 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7083             }
7084              
7085 0           $i = $left;
7086 0           last;
7087             }
7088             }
7089             }
7090              
7091             # rewrite character class or escape character
7092             elsif (my $char = character_class($char[$i],$modifier)) {
7093 0           $char[$i] = $char;
7094             }
7095              
7096             # P.794 29.2.161. split
7097             # in Chapter 29: Functions
7098             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7099              
7100             # P.951 split
7101             # in Chapter 27: Functions
7102             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7103              
7104             # said "The //m modifier is assumed when you split on the pattern /^/",
7105             # but perl5.008 is not so. Therefore, this software adds //m.
7106             # (and so on)
7107              
7108             # split(m/^/) --> split(m/^/m)
7109             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7110 0           $modifier .= 'm';
7111             }
7112              
7113             # /i modifier
7114             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin7::uc($char[$i]) ne Char::Elatin7::fc($char[$i]))) {
7115 0 0         if (CORE::length(Char::Elatin7::fc($char[$i])) == 1) {
7116 0           $char[$i] = '[' . Char::Elatin7::uc($char[$i]) . Char::Elatin7::fc($char[$i]) . ']';
7117             }
7118             else {
7119 0           $char[$i] = '(?:' . Char::Elatin7::uc($char[$i]) . '|' . Char::Elatin7::fc($char[$i]) . ')';
7120             }
7121             }
7122              
7123             # \u \l \U \L \F \Q \E
7124             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7125 0 0         if ($right_e < $left_e) {
7126 0           $char[$i] = '\\' . $char[$i];
7127             }
7128             }
7129             elsif ($char[$i] eq '\u') {
7130 0           $char[$i] = '@{[Char::Elatin7::ucfirst qq<';
7131 0           $left_e++;
7132             }
7133             elsif ($char[$i] eq '\l') {
7134 0           $char[$i] = '@{[Char::Elatin7::lcfirst qq<';
7135 0           $left_e++;
7136             }
7137             elsif ($char[$i] eq '\U') {
7138 0           $char[$i] = '@{[Char::Elatin7::uc qq<';
7139 0           $left_e++;
7140             }
7141             elsif ($char[$i] eq '\L') {
7142 0           $char[$i] = '@{[Char::Elatin7::lc qq<';
7143 0           $left_e++;
7144             }
7145             elsif ($char[$i] eq '\F') {
7146 0           $char[$i] = '@{[Char::Elatin7::fc qq<';
7147 0           $left_e++;
7148             }
7149             elsif ($char[$i] eq '\Q') {
7150 0           $char[$i] = '@{[CORE::quotemeta qq<';
7151 0           $left_e++;
7152             }
7153             elsif ($char[$i] eq '\E') {
7154 0 0         if ($right_e < $left_e) {
7155 0           $char[$i] = '>]}';
7156 0           $right_e++;
7157             }
7158             else {
7159 0           $char[$i] = '';
7160             }
7161             }
7162             elsif ($char[$i] eq '\Q') {
7163 0           while (1) {
7164 0 0         if (++$i > $#char) {
7165 0           last;
7166             }
7167 0 0         if ($char[$i] eq '\E') {
7168 0           last;
7169             }
7170             }
7171             }
7172             elsif ($char[$i] eq '\E') {
7173             }
7174              
7175             # $0 --> $0
7176             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7177 0 0         if ($ignorecase) {
7178 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7179             }
7180             }
7181             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
7182 0 0         if ($ignorecase) {
7183 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7184             }
7185             }
7186              
7187             # $$ --> $$
7188             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7189             }
7190              
7191             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7192             # $1, $2, $3 --> $1, $2, $3 otherwise
7193             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
7194 0           $char[$i] = e_capture($1);
7195 0 0         if ($ignorecase) {
7196 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7197             }
7198             }
7199             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
7200 0           $char[$i] = e_capture($1);
7201 0 0         if ($ignorecase) {
7202 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7203             }
7204             }
7205              
7206             # $$foo[ ... ] --> $ $foo->[ ... ]
7207             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7208 0           $char[$i] = e_capture($1.'->'.$2);
7209 0 0         if ($ignorecase) {
7210 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7211             }
7212             }
7213              
7214             # $$foo{ ... } --> $ $foo->{ ... }
7215             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7216 0           $char[$i] = e_capture($1.'->'.$2);
7217 0 0         if ($ignorecase) {
7218 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7219             }
7220             }
7221              
7222             # $$foo
7223             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
7224 0           $char[$i] = e_capture($1);
7225 0 0         if ($ignorecase) {
7226 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7227             }
7228             }
7229              
7230             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Elatin7::PREMATCH()
7231             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
7232 0 0         if ($ignorecase) {
7233 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::PREMATCH())]}';
7234             }
7235             else {
7236 0           $char[$i] = '@{[Char::Elatin7::PREMATCH()]}';
7237             }
7238             }
7239              
7240             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Elatin7::MATCH()
7241             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
7242 0 0         if ($ignorecase) {
7243 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::MATCH())]}';
7244             }
7245             else {
7246 0           $char[$i] = '@{[Char::Elatin7::MATCH()]}';
7247             }
7248             }
7249              
7250             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Elatin7::POSTMATCH()
7251             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
7252 0 0         if ($ignorecase) {
7253 0           $char[$i] = '@{[Char::Elatin7::ignorecase(Char::Elatin7::POSTMATCH())]}';
7254             }
7255             else {
7256 0           $char[$i] = '@{[Char::Elatin7::POSTMATCH()]}';
7257             }
7258             }
7259              
7260             # ${ foo }
7261             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
7262 0 0         if ($ignorecase) {
7263 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $1 . ')]}';
7264             }
7265             }
7266              
7267             # ${ ... }
7268             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
7269 0           $char[$i] = e_capture($1);
7270 0 0         if ($ignorecase) {
7271 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7272             }
7273             }
7274              
7275             # $scalar or @array
7276             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7277 0           $char[$i] = e_string($char[$i]);
7278 0 0         if ($ignorecase) {
7279 0           $char[$i] = '@{[Char::Elatin7::ignorecase(' . $char[$i] . ')]}';
7280             }
7281             }
7282              
7283             # quote character before ? + * {
7284             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7285 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7286             }
7287             else {
7288 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7289             }
7290             }
7291             }
7292              
7293             # make regexp string
7294 0           $modifier =~ tr/i//d;
7295 0 0         if ($left_e > $right_e) {
7296 0           return join '', 'Char::Elatin7::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7297             }
7298 0           return join '', 'Char::Elatin7::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7299             }
7300              
7301             #
7302             # escape regexp of split qr''
7303             #
7304             sub e_split_q {
7305 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7306 0   0       $modifier ||= '';
7307              
7308 0           $modifier =~ tr/p//d;
7309 0 0         if ($modifier =~ /([adlu])/oxms) {
7310 0           my $line = 0;
7311 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7312 0 0         if ($filename ne __FILE__) {
7313 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7314 0           last;
7315             }
7316             }
7317 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7318             }
7319              
7320 0           $slash = 'div';
7321              
7322             # /b /B modifier
7323 0 0         if ($modifier =~ tr/bB//d) {
7324 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7325             }
7326              
7327 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7328              
7329             # split regexp
7330 0           my @char = $string =~ /\G(
7331             \[\:\^ [a-z]+ \:\] |
7332             \[\: [a-z]+ \:\] |
7333             \[\^ |
7334             \\? (?:$q_char)
7335             )/oxmsg;
7336              
7337             # unescape character
7338 0           for (my $i=0; $i <= $#char; $i++) {
7339 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7340             }
7341              
7342             # open character class [...]
7343 0           elsif ($char[$i] eq '[') {
7344 0           my $left = $i;
7345 0 0         if ($char[$i+1] eq ']') {
7346 0           $i++;
7347             }
7348 0           while (1) {
7349 0 0         if (++$i > $#char) {
7350 0           die __FILE__, ": Unmatched [] in regexp";
7351             }
7352 0 0         if ($char[$i] eq ']') {
7353 0           my $right = $i;
7354              
7355             # [...]
7356 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
7357              
7358 0           $i = $left;
7359 0           last;
7360             }
7361             }
7362             }
7363              
7364             # open character class [^...]
7365             elsif ($char[$i] eq '[^') {
7366 0           my $left = $i;
7367 0 0         if ($char[$i+1] eq ']') {
7368 0           $i++;
7369             }
7370 0           while (1) {
7371 0 0         if (++$i > $#char) {
7372 0           die __FILE__, ": Unmatched [] in regexp";
7373             }
7374 0 0         if ($char[$i] eq ']') {
7375 0           my $right = $i;
7376              
7377             # [^...]
7378 0           splice @char, $left, $right-$left+1, Char::Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7379              
7380 0           $i = $left;
7381 0           last;
7382             }
7383             }
7384             }
7385              
7386             # rewrite character class or escape character
7387             elsif (my $char = character_class($char[$i],$modifier)) {
7388 0           $char[$i] = $char;
7389             }
7390              
7391             # split(m/^/) --> split(m/^/m)
7392             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7393 0           $modifier .= 'm';
7394             }
7395              
7396             # /i modifier
7397             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Elatin7::uc($char[$i]) ne Char::Elatin7::fc($char[$i]))) {
7398 0 0         if (CORE::length(Char::Elatin7::fc($char[$i])) == 1) {
7399 0           $char[$i] = '[' . Char::Elatin7::uc($char[$i]) . Char::Elatin7::fc($char[$i]) . ']';
7400             }
7401             else {
7402 0           $char[$i] = '(?:' . Char::Elatin7::uc($char[$i]) . '|' . Char::Elatin7::fc($char[$i]) . ')';
7403             }
7404             }
7405              
7406             # quote character before ? + * {
7407             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7408 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7409             }
7410             else {
7411 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7412             }
7413             }
7414             }
7415              
7416 0           $modifier =~ tr/i//d;
7417 0           return join '', 'Char::Elatin7::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7418             }
7419              
7420             #
7421             # instead of Carp::carp
7422             #
7423             sub carp {
7424 0     0 0   my($package,$filename,$line) = caller(1);
7425 0           print STDERR "@_ at $filename line $line.\n";
7426             }
7427              
7428             #
7429             # instead of Carp::croak
7430             #
7431             sub croak {
7432 0     0 0   my($package,$filename,$line) = caller(1);
7433 0           print STDERR "@_ at $filename line $line.\n";
7434 0           die "\n";
7435             }
7436              
7437             #
7438             # instead of Carp::cluck
7439             #
7440             sub cluck {
7441 0     0 0   my $i = 0;
7442 0           my @cluck = ();
7443 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7444 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7445 0           $i++;
7446             }
7447 0           print STDERR CORE::reverse @cluck;
7448 0           print STDERR "\n";
7449 0           carp @_;
7450             }
7451              
7452             #
7453             # instead of Carp::confess
7454             #
7455             sub confess {
7456 0     0 0   my $i = 0;
7457 0           my @confess = ();
7458 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7459 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7460 0           $i++;
7461             }
7462 0           print STDERR CORE::reverse @confess;
7463 0           print STDERR "\n";
7464 0           croak @_;
7465             }
7466              
7467             1;
7468              
7469             __END__