File Coverage

blib/lib/Elatin7.pm
Criterion Covered Total %
statement 865 3080 28.0
branch 944 2674 35.3
condition 99 373 26.5
subroutine 67 125 53.6
pod 7 74 9.4
total 1982 6326 31.3


line stmt bran cond sub pod time code
1             package Elatin7;
2             ######################################################################
3             #
4             # Elatin7 - Run-time routines for Latin7.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin7/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   2591 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         444  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             # 12.3. Delaying use Until Runtime
15             # in Chapter 12. Packages, Libraries, and Modules
16             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
17             # (and so on)
18              
19             # Version numbers should be boring
20             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
21             # For the impatient, the disinterested or those who just want to follow
22             # a recipe, my advice for all modules is this:
23             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
24             # $VERSION = eval $VERSION;
25              
26 200     200   9813 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   749  
  200         228  
  200         21537  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   901 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         205 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         19668 if (CORE::ord('A') != 0x41) {
38             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
39             }
40             }
41              
42             BEGIN {
43              
44             # instead of utf8.pm
45 200     200   9659 CORE::eval q{
  200     200   773  
  200     72   262  
  200         16510  
  48         3266  
  56         3859  
  52         3547  
  44         3056  
46             no warnings qw(redefine);
47             *utf8::upgrade = sub { CORE::length $_[0] };
48             *utf8::downgrade = sub { 1 };
49             *utf8::encode = sub { };
50             *utf8::decode = sub { 1 };
51             *utf8::is_utf8 = sub { };
52             *utf8::valid = sub { 1 };
53             };
54 200 50       73843 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65 0         0 BEGIN {
66 200     200   433 my $genpkg = "Symbol::";
67 200         6508 my $genseq = 0;
68              
69             sub gensym () {
70 0     0 0 0 my $name = "GEN" . $genseq++;
71              
72             # here, no strict qw(refs); if strict.pm exists
73              
74 0         0 my $ref = \*{$genpkg . $name};
  0         0  
75 0         0 delete $$genpkg{$name};
76 0         0 return $ref;
77             }
78              
79             sub qualify ($;$) {
80 0     0 0 0 my ($name) = @_;
81 0 0 0     0 if (!ref($name) && (Elatin7::index($name, '::') == -1) && (Elatin7::index($name, "'") == -1)) {
      0        
82 0         0 my $pkg;
83 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
84              
85             # Global names: special character, "^xyz", or other.
86 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
89 0         0 $pkg = "main";
90             }
91             else {
92 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
93             }
94 0         0 $name = $pkg . "::" . $name;
95             }
96 0         0 return $name;
97             }
98              
99             sub qualify_to_ref ($;$) {
100              
101             # here, no strict qw(refs); if strict.pm exists
102              
103 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
104             }
105             }
106              
107             # Column: local $@
108             # in Chapter 9. Osaete okitai Perl no kiso
109             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
110             # (and so on)
111              
112             # use strict; if strict.pm exists
113             BEGIN {
114 200 50   200   279 if (CORE::eval { local $@; CORE::require strict }) {
  200         254  
  200         1535  
115 200         15750 strict::->import;
116             }
117             }
118              
119             # P.714 29.2.39. flock
120             # in Chapter 29: Functions
121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
122              
123             # P.863 flock
124             # in Chapter 27: Functions
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126              
127             sub LOCK_SH() {1}
128             sub LOCK_EX() {2}
129             sub LOCK_UN() {8}
130             sub LOCK_NB() {4}
131              
132             # instead of Carp.pm
133             sub carp;
134             sub croak;
135             sub cluck;
136             sub confess;
137              
138             # 6.18. Matching Multiple-Byte Characters
139             # in Chapter 6. Pattern Matching
140             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
141             # (and so on)
142              
143             # regexp of character
144 200     200   10739 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   752  
  200         223  
  200         8805  
145 200     200   9099 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   713  
  200         233  
  200         9343  
146 200     200   8606 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   676  
  200         228  
  200         10099  
147              
148             #
149             # Latin-7 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   8792 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   694  
  200         217  
  200         232095  
157              
158             #
159             # Latin-7 case conversion
160             #
161             my %lc = ();
162             @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)} =
163             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             my %uc = ();
165             @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)} =
166             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);
167             my %fc = ();
168             @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)} =
169             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);
170              
171             if (0) {
172             }
173              
174             elsif (__PACKAGE__ =~ / \b Elatin7 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-13 | iec[- ]?8859-13 | latin-?7 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA8" => "\xB8", # LATIN LETTER O WITH STROKE
183             "\xAA" => "\xBA", # LATIN LETTER R WITH CEDILLA
184             "\xAF" => "\xBF", # LATIN LETTER AE
185             "\xC0" => "\xE0", # LATIN LETTER A WITH OGONEK
186             "\xC1" => "\xE1", # LATIN LETTER I WITH OGONEK
187             "\xC2" => "\xE2", # LATIN LETTER A WITH MACRON
188             "\xC3" => "\xE3", # LATIN LETTER C WITH ACUTE
189             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
190             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
191             "\xC6" => "\xE6", # LATIN LETTER E WITH OGONEK
192             "\xC7" => "\xE7", # LATIN LETTER E WITH MACRON
193             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
194             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
195             "\xCA" => "\xEA", # LATIN LETTER Z WITH ACUTE
196             "\xCB" => "\xEB", # LATIN LETTER E WITH DOT ABOVE
197             "\xCC" => "\xEC", # LATIN LETTER G WITH CEDILLA
198             "\xCD" => "\xED", # LATIN LETTER K WITH CEDILLA
199             "\xCE" => "\xEE", # LATIN LETTER I WITH MACRON
200             "\xCF" => "\xEF", # LATIN LETTER L WITH CEDILLA
201             "\xD0" => "\xF0", # LATIN LETTER S WITH CARON
202             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
203             "\xD2" => "\xF2", # LATIN LETTER N WITH CEDILLA
204             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
205             "\xD4" => "\xF4", # LATIN LETTER O WITH MACRON
206             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
207             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
208             "\xD8" => "\xF8", # LATIN LETTER U WITH OGONEK
209             "\xD9" => "\xF9", # LATIN LETTER L WITH STROKE
210             "\xDA" => "\xFA", # LATIN LETTER S WITH ACUTE
211             "\xDB" => "\xFB", # LATIN LETTER U WITH MACRON
212             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
213             "\xDD" => "\xFD", # LATIN LETTER Z WITH DOT ABOVE
214             "\xDE" => "\xFE", # LATIN LETTER Z WITH CARON
215             );
216              
217             %uc = (%uc,
218             "\xB8" => "\xA8", # LATIN LETTER O WITH STROKE
219             "\xBA" => "\xAA", # LATIN LETTER R WITH CEDILLA
220             "\xBF" => "\xAF", # LATIN LETTER AE
221             "\xE0" => "\xC0", # LATIN LETTER A WITH OGONEK
222             "\xE1" => "\xC1", # LATIN LETTER I WITH OGONEK
223             "\xE2" => "\xC2", # LATIN LETTER A WITH MACRON
224             "\xE3" => "\xC3", # LATIN LETTER C WITH ACUTE
225             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
226             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
227             "\xE6" => "\xC6", # LATIN LETTER E WITH OGONEK
228             "\xE7" => "\xC7", # LATIN LETTER E WITH MACRON
229             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
230             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
231             "\xEA" => "\xCA", # LATIN LETTER Z WITH ACUTE
232             "\xEB" => "\xCB", # LATIN LETTER E WITH DOT ABOVE
233             "\xEC" => "\xCC", # LATIN LETTER G WITH CEDILLA
234             "\xED" => "\xCD", # LATIN LETTER K WITH CEDILLA
235             "\xEE" => "\xCE", # LATIN LETTER I WITH MACRON
236             "\xEF" => "\xCF", # LATIN LETTER L WITH CEDILLA
237             "\xF0" => "\xD0", # LATIN LETTER S WITH CARON
238             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
239             "\xF2" => "\xD2", # LATIN LETTER N WITH CEDILLA
240             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
241             "\xF4" => "\xD4", # LATIN LETTER O WITH MACRON
242             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
243             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
244             "\xF8" => "\xD8", # LATIN LETTER U WITH OGONEK
245             "\xF9" => "\xD9", # LATIN LETTER L WITH STROKE
246             "\xFA" => "\xDA", # LATIN LETTER S WITH ACUTE
247             "\xFB" => "\xDB", # LATIN LETTER U WITH MACRON
248             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
249             "\xFD" => "\xDD", # LATIN LETTER Z WITH DOT ABOVE
250             "\xFE" => "\xDE", # LATIN LETTER Z WITH CARON
251             );
252              
253             %fc = (%fc,
254             "\xA8" => "\xB8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
255             "\xAA" => "\xBA", # LATIN CAPITAL LETTER R WITH CEDILLA --> LATIN SMALL LETTER R WITH CEDILLA
256             "\xAF" => "\xBF", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
257             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
258             "\xC1" => "\xE1", # LATIN CAPITAL LETTER I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
259             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
260             "\xC3" => "\xE3", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
261             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
262             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
263             "\xC6" => "\xE6", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
264             "\xC7" => "\xE7", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
265             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
266             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
267             "\xCA" => "\xEA", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
268             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
269             "\xCC" => "\xEC", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
270             "\xCD" => "\xED", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
271             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
272             "\xCF" => "\xEF", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
273             "\xD0" => "\xF0", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
274             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
275             "\xD2" => "\xF2", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
276             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
277             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
278             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
279             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
280             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
281             "\xD9" => "\xF9", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
282             "\xDA" => "\xFA", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
283             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
284             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
285             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
286             "\xDE" => "\xFE", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
287             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
288             );
289             }
290              
291             else {
292             croak "Don't know my package name '@{[__PACKAGE__]}'";
293             }
294              
295             #
296             # @ARGV wildcard globbing
297             #
298             sub import {
299              
300 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
301 0         0 my @argv = ();
302 0         0 for (@ARGV) {
303              
304             # has space
305 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
306 0 0       0 if (my @glob = Elatin7::glob(qq{"$_"})) {
307 0         0 push @argv, @glob;
308             }
309             else {
310 0         0 push @argv, $_;
311             }
312             }
313              
314             # has wildcard metachar
315             elsif (/\A (?:$q_char)*? [*?] /oxms) {
316 0 0       0 if (my @glob = Elatin7::glob($_)) {
317 0         0 push @argv, @glob;
318             }
319             else {
320 0         0 push @argv, $_;
321             }
322             }
323              
324             # no wildcard globbing
325             else {
326 0         0 push @argv, $_;
327             }
328             }
329 0         0 @ARGV = @argv;
330             }
331              
332 0         0 *Char::ord = \&Latin7::ord;
333 0         0 *Char::ord_ = \&Latin7::ord_;
334 0         0 *Char::reverse = \&Latin7::reverse;
335 0         0 *Char::getc = \&Latin7::getc;
336 0         0 *Char::length = \&Latin7::length;
337 0         0 *Char::substr = \&Latin7::substr;
338 0         0 *Char::index = \&Latin7::index;
339 0         0 *Char::rindex = \&Latin7::rindex;
340 0         0 *Char::eval = \&Latin7::eval;
341 0         0 *Char::escape = \&Latin7::escape;
342 0         0 *Char::escape_token = \&Latin7::escape_token;
343 0         0 *Char::escape_script = \&Latin7::escape_script;
344             }
345              
346             # P.230 Care with Prototypes
347             # in Chapter 6: Subroutines
348             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
349             #
350             # If you aren't careful, you can get yourself into trouble with prototypes.
351             # But if you are careful, you can do a lot of neat things with them. This is
352             # all very powerful, of course, and should only be used in moderation to make
353             # the world a better place.
354              
355             # P.332 Care with Prototypes
356             # in Chapter 7: Subroutines
357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
358             #
359             # If you aren't careful, you can get yourself into trouble with prototypes.
360             # But if you are careful, you can do a lot of neat things with them. This is
361             # all very powerful, of course, and should only be used in moderation to make
362             # the world a better place.
363              
364             #
365             # Prototypes of subroutines
366             #
367       0     sub unimport {}
368             sub Elatin7::split(;$$$);
369             sub Elatin7::tr($$$$;$);
370             sub Elatin7::chop(@);
371             sub Elatin7::index($$;$);
372             sub Elatin7::rindex($$;$);
373             sub Elatin7::lcfirst(@);
374             sub Elatin7::lcfirst_();
375             sub Elatin7::lc(@);
376             sub Elatin7::lc_();
377             sub Elatin7::ucfirst(@);
378             sub Elatin7::ucfirst_();
379             sub Elatin7::uc(@);
380             sub Elatin7::uc_();
381             sub Elatin7::fc(@);
382             sub Elatin7::fc_();
383             sub Elatin7::ignorecase;
384             sub Elatin7::classic_character_class;
385             sub Elatin7::capture;
386             sub Elatin7::chr(;$);
387             sub Elatin7::chr_();
388             sub Elatin7::glob($);
389             sub Elatin7::glob_();
390              
391             sub Latin7::ord(;$);
392             sub Latin7::ord_();
393             sub Latin7::reverse(@);
394             sub Latin7::getc(;*@);
395             sub Latin7::length(;$);
396             sub Latin7::substr($$;$$);
397             sub Latin7::index($$;$);
398             sub Latin7::rindex($$;$);
399             sub Latin7::escape(;$);
400              
401             #
402             # Regexp work
403             #
404 200     200   11130 BEGIN { CORE::eval q{ use vars qw(
  200     200   855  
  200         247  
  200         55275  
405             $Latin7::re_a
406             $Latin7::re_t
407             $Latin7::re_n
408             $Latin7::re_r
409             ) } }
410              
411             #
412             # Character class
413             #
414 200     200   11532 BEGIN { CORE::eval q{ use vars qw(
  200     200   775  
  200         228  
  200         1816956  
415             $dot
416             $dot_s
417             $eD
418             $eS
419             $eW
420             $eH
421             $eV
422             $eR
423             $eN
424             $not_alnum
425             $not_alpha
426             $not_ascii
427             $not_blank
428             $not_cntrl
429             $not_digit
430             $not_graph
431             $not_lower
432             $not_lower_i
433             $not_print
434             $not_punct
435             $not_space
436             $not_upper
437             $not_upper_i
438             $not_word
439             $not_xdigit
440             $eb
441             $eB
442             ) } }
443              
444             ${Elatin7::dot} = qr{(?>[^\x0A])};
445             ${Elatin7::dot_s} = qr{(?>[\x00-\xFF])};
446             ${Elatin7::eD} = qr{(?>[^0-9])};
447              
448             # Vertical tabs are now whitespace
449             # \s in a regex now matches a vertical tab in all circumstances.
450             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
451             # ${Elatin7::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
452             # ${Elatin7::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
453             ${Elatin7::eS} = qr{(?>[^\s])};
454              
455             ${Elatin7::eW} = qr{(?>[^0-9A-Z_a-z])};
456             ${Elatin7::eH} = qr{(?>[^\x09\x20])};
457             ${Elatin7::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
458             ${Elatin7::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
459             ${Elatin7::eN} = qr{(?>[^\x0A])};
460             ${Elatin7::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
461             ${Elatin7::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
462             ${Elatin7::not_ascii} = qr{(?>[^\x00-\x7F])};
463             ${Elatin7::not_blank} = qr{(?>[^\x09\x20])};
464             ${Elatin7::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
465             ${Elatin7::not_digit} = qr{(?>[^\x30-\x39])};
466             ${Elatin7::not_graph} = qr{(?>[^\x21-\x7F])};
467             ${Elatin7::not_lower} = qr{(?>[^\x61-\x7A])};
468             ${Elatin7::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
469             # ${Elatin7::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
470             ${Elatin7::not_print} = qr{(?>[^\x20-\x7F])};
471             ${Elatin7::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
472             ${Elatin7::not_space} = qr{(?>[^\s\x0B])};
473             ${Elatin7::not_upper} = qr{(?>[^\x41-\x5A])};
474             ${Elatin7::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
475             # ${Elatin7::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
476             ${Elatin7::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
477             ${Elatin7::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
478             ${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))};
479             ${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]))};
480              
481             # avoid: Name "Elatin7::foo" used only once: possible typo at here.
482             ${Elatin7::dot} = ${Elatin7::dot};
483             ${Elatin7::dot_s} = ${Elatin7::dot_s};
484             ${Elatin7::eD} = ${Elatin7::eD};
485             ${Elatin7::eS} = ${Elatin7::eS};
486             ${Elatin7::eW} = ${Elatin7::eW};
487             ${Elatin7::eH} = ${Elatin7::eH};
488             ${Elatin7::eV} = ${Elatin7::eV};
489             ${Elatin7::eR} = ${Elatin7::eR};
490             ${Elatin7::eN} = ${Elatin7::eN};
491             ${Elatin7::not_alnum} = ${Elatin7::not_alnum};
492             ${Elatin7::not_alpha} = ${Elatin7::not_alpha};
493             ${Elatin7::not_ascii} = ${Elatin7::not_ascii};
494             ${Elatin7::not_blank} = ${Elatin7::not_blank};
495             ${Elatin7::not_cntrl} = ${Elatin7::not_cntrl};
496             ${Elatin7::not_digit} = ${Elatin7::not_digit};
497             ${Elatin7::not_graph} = ${Elatin7::not_graph};
498             ${Elatin7::not_lower} = ${Elatin7::not_lower};
499             ${Elatin7::not_lower_i} = ${Elatin7::not_lower_i};
500             ${Elatin7::not_print} = ${Elatin7::not_print};
501             ${Elatin7::not_punct} = ${Elatin7::not_punct};
502             ${Elatin7::not_space} = ${Elatin7::not_space};
503             ${Elatin7::not_upper} = ${Elatin7::not_upper};
504             ${Elatin7::not_upper_i} = ${Elatin7::not_upper_i};
505             ${Elatin7::not_word} = ${Elatin7::not_word};
506             ${Elatin7::not_xdigit} = ${Elatin7::not_xdigit};
507             ${Elatin7::eb} = ${Elatin7::eb};
508             ${Elatin7::eB} = ${Elatin7::eB};
509              
510             #
511             # Latin-7 split
512             #
513             sub Elatin7::split(;$$$) {
514              
515             # P.794 29.2.161. split
516             # in Chapter 29: Functions
517             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
518              
519             # P.951 split
520             # in Chapter 27: Functions
521             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
522              
523 0     0 0 0 my $pattern = $_[0];
524 0         0 my $string = $_[1];
525 0         0 my $limit = $_[2];
526              
527             # if $pattern is also omitted or is the literal space, " "
528 0 0       0 if (not defined $pattern) {
529 0         0 $pattern = ' ';
530             }
531              
532             # if $string is omitted, the function splits the $_ string
533 0 0       0 if (not defined $string) {
534 0 0       0 if (defined $_) {
535 0         0 $string = $_;
536             }
537             else {
538 0         0 $string = '';
539             }
540             }
541              
542 0         0 my @split = ();
543              
544             # when string is empty
545 0 0       0 if ($string eq '') {
    0          
546              
547             # resulting list value in list context
548 0 0       0 if (wantarray) {
549 0         0 return @split;
550             }
551              
552             # count of substrings in scalar context
553             else {
554 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
555 0         0 @_ = @split;
556 0         0 return scalar @_;
557             }
558             }
559              
560             # split's first argument is more consistently interpreted
561             #
562             # After some changes earlier in v5.17, split's behavior has been simplified:
563             # if the PATTERN argument evaluates to a string containing one space, it is
564             # treated the way that a literal string containing one space once was.
565             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
566              
567             # if $pattern is also omitted or is the literal space, " ", the function splits
568             # on whitespace, /\s+/, after skipping any leading whitespace
569             # (and so on)
570              
571             elsif ($pattern eq ' ') {
572 0 0       0 if (not defined $limit) {
573 0         0 return CORE::split(' ', $string);
574             }
575             else {
576 0         0 return CORE::split(' ', $string, $limit);
577             }
578             }
579              
580             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
581 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
582              
583             # a pattern capable of matching either the null string or something longer than the
584             # null string will split the value of $string into separate characters wherever it
585             # matches the null string between characters
586             # (and so on)
587              
588 0 0       0 if ('' =~ / \A $pattern \z /xms) {
589 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
590 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
591              
592             # P.1024 Appendix W.10 Multibyte Processing
593             # of ISBN 1-56592-224-7 CJKV Information Processing
594             # (and so on)
595              
596             # the //m modifier is assumed when you split on the pattern /^/
597             # (and so on)
598              
599             # V
600 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
601              
602             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
603             # is included in the resulting list, interspersed with the fields that are ordinarily returned
604             # (and so on)
605              
606 0         0 local $@;
607 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
608 0         0 push @split, CORE::eval('$' . $digit);
609             }
610             }
611             }
612              
613             else {
614 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
615              
616             # V
617 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
618 0         0 local $@;
619 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
620 0         0 push @split, CORE::eval('$' . $digit);
621             }
622             }
623             }
624             }
625              
626             elsif ($limit > 0) {
627 0 0       0 if ('' =~ / \A $pattern \z /xms) {
628 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
629 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
630              
631             # V
632 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
633 0         0 local $@;
634 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
635 0         0 push @split, CORE::eval('$' . $digit);
636             }
637             }
638             }
639             }
640             else {
641 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
642 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
643              
644             # V
645 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
646 0         0 local $@;
647 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
648 0         0 push @split, CORE::eval('$' . $digit);
649             }
650             }
651             }
652             }
653             }
654              
655 0 0       0 if (CORE::length($string) > 0) {
656 0         0 push @split, $string;
657             }
658              
659             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
660 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
661 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
662 0         0 pop @split;
663             }
664             }
665              
666             # resulting list value in list context
667 0 0       0 if (wantarray) {
668 0         0 return @split;
669             }
670              
671             # count of substrings in scalar context
672             else {
673 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
674 0         0 @_ = @split;
675 0         0 return scalar @_;
676             }
677             }
678              
679             #
680             # get last subexpression offsets
681             #
682             sub _last_subexpression_offsets {
683 0     0   0 my $pattern = $_[0];
684              
685             # remove comment
686 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
687              
688 0         0 my $modifier = '';
689 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
690 0         0 $modifier = $1;
691 0         0 $modifier =~ s/-[A-Za-z]*//;
692             }
693              
694             # with /x modifier
695 0         0 my @char = ();
696 0 0       0 if ($modifier =~ /x/oxms) {
697 0         0 @char = $pattern =~ /\G((?>
698             [^\\\#\[\(] |
699             \\ $q_char |
700             \# (?>[^\n]*) $ |
701             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
702             \(\? |
703             $q_char
704             ))/oxmsg;
705             }
706              
707             # without /x modifier
708             else {
709 0         0 @char = $pattern =~ /\G((?>
710             [^\\\[\(] |
711             \\ $q_char |
712             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
713             \(\? |
714             $q_char
715             ))/oxmsg;
716             }
717              
718 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
719             }
720              
721             #
722             # Latin-7 transliteration (tr///)
723             #
724             sub Elatin7::tr($$$$;$) {
725              
726 0     0 0 0 my $bind_operator = $_[1];
727 0         0 my $searchlist = $_[2];
728 0         0 my $replacementlist = $_[3];
729 0   0     0 my $modifier = $_[4] || '';
730              
731 0 0       0 if ($modifier =~ /r/oxms) {
732 0 0       0 if ($bind_operator =~ / !~ /oxms) {
733 0         0 croak "Using !~ with tr///r doesn't make sense";
734             }
735             }
736              
737 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
738 0         0 my @searchlist = _charlist_tr($searchlist);
739 0         0 my @replacementlist = _charlist_tr($replacementlist);
740              
741 0         0 my %tr = ();
742 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
743 0 0       0 if (not exists $tr{$searchlist[$i]}) {
744 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
745 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
746             }
747             elsif ($modifier =~ /d/oxms) {
748 0         0 $tr{$searchlist[$i]} = '';
749             }
750             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
751 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
752             }
753             else {
754 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
755             }
756             }
757             }
758              
759 0         0 my $tr = 0;
760 0         0 my $replaced = '';
761 0 0       0 if ($modifier =~ /c/oxms) {
762 0         0 while (defined(my $char = shift @char)) {
763 0 0       0 if (not exists $tr{$char}) {
764 0 0       0 if (defined $replacementlist[0]) {
765 0         0 $replaced .= $replacementlist[0];
766             }
767 0         0 $tr++;
768 0 0       0 if ($modifier =~ /s/oxms) {
769 0   0     0 while (@char and (not exists $tr{$char[0]})) {
770 0         0 shift @char;
771 0         0 $tr++;
772             }
773             }
774             }
775             else {
776 0         0 $replaced .= $char;
777             }
778             }
779             }
780             else {
781 0         0 while (defined(my $char = shift @char)) {
782 0 0       0 if (exists $tr{$char}) {
783 0         0 $replaced .= $tr{$char};
784 0         0 $tr++;
785 0 0       0 if ($modifier =~ /s/oxms) {
786 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
787 0         0 shift @char;
788 0         0 $tr++;
789             }
790             }
791             }
792             else {
793 0         0 $replaced .= $char;
794             }
795             }
796             }
797              
798 0 0       0 if ($modifier =~ /r/oxms) {
799 0         0 return $replaced;
800             }
801             else {
802 0         0 $_[0] = $replaced;
803 0 0       0 if ($bind_operator =~ / !~ /oxms) {
804 0         0 return not $tr;
805             }
806             else {
807 0         0 return $tr;
808             }
809             }
810             }
811              
812             #
813             # Latin-7 chop
814             #
815             sub Elatin7::chop(@) {
816              
817 0     0 0 0 my $chop;
818 0 0       0 if (@_ == 0) {
819 0         0 my @char = /\G (?>$q_char) /oxmsg;
820 0         0 $chop = pop @char;
821 0         0 $_ = join '', @char;
822             }
823             else {
824 0         0 for (@_) {
825 0         0 my @char = /\G (?>$q_char) /oxmsg;
826 0         0 $chop = pop @char;
827 0         0 $_ = join '', @char;
828             }
829             }
830 0         0 return $chop;
831             }
832              
833             #
834             # Latin-7 index by octet
835             #
836             sub Elatin7::index($$;$) {
837              
838 0     0 1 0 my($str,$substr,$position) = @_;
839 0   0     0 $position ||= 0;
840 0         0 my $pos = 0;
841              
842 0         0 while ($pos < CORE::length($str)) {
843 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
844 0 0       0 if ($pos >= $position) {
845 0         0 return $pos;
846             }
847             }
848 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
849 0         0 $pos += CORE::length($1);
850             }
851             else {
852 0         0 $pos += 1;
853             }
854             }
855 0         0 return -1;
856             }
857              
858             #
859             # Latin-7 reverse index
860             #
861             sub Elatin7::rindex($$;$) {
862              
863 0     0 0 0 my($str,$substr,$position) = @_;
864 0   0     0 $position ||= CORE::length($str) - 1;
865 0         0 my $pos = 0;
866 0         0 my $rindex = -1;
867              
868 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
869 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
870 0         0 $rindex = $pos;
871             }
872 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
873 0         0 $pos += CORE::length($1);
874             }
875             else {
876 0         0 $pos += 1;
877             }
878             }
879 0         0 return $rindex;
880             }
881              
882             #
883             # Latin-7 lower case first with parameter
884             #
885             sub Elatin7::lcfirst(@) {
886 0 0   0 0 0 if (@_) {
887 0         0 my $s = shift @_;
888 0 0 0     0 if (@_ and wantarray) {
889 0         0 return Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
890             }
891             else {
892 0         0 return Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
893             }
894             }
895             else {
896 0         0 return Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
897             }
898             }
899              
900             #
901             # Latin-7 lower case first without parameter
902             #
903             sub Elatin7::lcfirst_() {
904 0     0 0 0 return Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
905             }
906              
907             #
908             # Latin-7 lower case with parameter
909             #
910             sub Elatin7::lc(@) {
911 0 0   0 0 0 if (@_) {
912 0         0 my $s = shift @_;
913 0 0 0     0 if (@_ and wantarray) {
914 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
915             }
916             else {
917 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
918             }
919             }
920             else {
921 0         0 return Elatin7::lc_();
922             }
923             }
924              
925             #
926             # Latin-7 lower case without parameter
927             #
928             sub Elatin7::lc_() {
929 0     0 0 0 my $s = $_;
930 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
931             }
932              
933             #
934             # Latin-7 upper case first with parameter
935             #
936             sub Elatin7::ucfirst(@) {
937 0 0   0 0 0 if (@_) {
938 0         0 my $s = shift @_;
939 0 0 0     0 if (@_ and wantarray) {
940 0         0 return Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
941             }
942             else {
943 0         0 return Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
944             }
945             }
946             else {
947 0         0 return Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
948             }
949             }
950              
951             #
952             # Latin-7 upper case first without parameter
953             #
954             sub Elatin7::ucfirst_() {
955 0     0 0 0 return Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
956             }
957              
958             #
959             # Latin-7 upper case with parameter
960             #
961             sub Elatin7::uc(@) {
962 174 50   174 0 220 if (@_) {
963 174         177 my $s = shift @_;
964 174 50 33     336 if (@_ and wantarray) {
965 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
966             }
967             else {
968 174 100       464 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         536  
969             }
970             }
971             else {
972 0         0 return Elatin7::uc_();
973             }
974             }
975              
976             #
977             # Latin-7 upper case without parameter
978             #
979             sub Elatin7::uc_() {
980 0     0 0 0 my $s = $_;
981 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
982             }
983              
984             #
985             # Latin-7 fold case with parameter
986             #
987             sub Elatin7::fc(@) {
988 197 50   197 0 222 if (@_) {
989 197         167 my $s = shift @_;
990 197 50 33     344 if (@_ and wantarray) {
991 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
992             }
993             else {
994 197 100       440 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         1062  
995             }
996             }
997             else {
998 0         0 return Elatin7::fc_();
999             }
1000             }
1001              
1002             #
1003             # Latin-7 fold case without parameter
1004             #
1005             sub Elatin7::fc_() {
1006 0     0 0 0 my $s = $_;
1007 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1008             }
1009              
1010             #
1011             # Latin-7 regexp capture
1012             #
1013             {
1014             sub Elatin7::capture {
1015 0     0 1 0 return $_[0];
1016             }
1017             }
1018              
1019             #
1020             # Latin-7 regexp ignore case modifier
1021             #
1022             sub Elatin7::ignorecase {
1023              
1024 0     0 0 0 my @string = @_;
1025 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1026              
1027             # ignore case of $scalar or @array
1028 0         0 for my $string (@string) {
1029              
1030             # split regexp
1031 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1032              
1033             # unescape character
1034 0         0 for (my $i=0; $i <= $#char; $i++) {
1035 0 0       0 next if not defined $char[$i];
1036              
1037             # open character class [...]
1038 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1039 0         0 my $left = $i;
1040              
1041             # [] make die "unmatched [] in regexp ...\n"
1042              
1043 0 0       0 if ($char[$i+1] eq ']') {
1044 0         0 $i++;
1045             }
1046              
1047 0         0 while (1) {
1048 0 0       0 if (++$i > $#char) {
1049 0         0 croak "Unmatched [] in regexp";
1050             }
1051 0 0       0 if ($char[$i] eq ']') {
1052 0         0 my $right = $i;
1053 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1054              
1055             # escape character
1056 0         0 for my $char (@charlist) {
1057 0 0       0 if (0) {
1058             }
1059              
1060 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1061 0         0 $char = '\\' . $char;
1062             }
1063             }
1064              
1065             # [...]
1066 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1067              
1068 0         0 $i = $left;
1069 0         0 last;
1070             }
1071             }
1072             }
1073              
1074             # open character class [^...]
1075             elsif ($char[$i] eq '[^') {
1076 0         0 my $left = $i;
1077              
1078             # [^] make die "unmatched [] in regexp ...\n"
1079              
1080 0 0       0 if ($char[$i+1] eq ']') {
1081 0         0 $i++;
1082             }
1083              
1084 0         0 while (1) {
1085 0 0       0 if (++$i > $#char) {
1086 0         0 croak "Unmatched [] in regexp";
1087             }
1088 0 0       0 if ($char[$i] eq ']') {
1089 0         0 my $right = $i;
1090 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1091              
1092             # escape character
1093 0         0 for my $char (@charlist) {
1094 0 0       0 if (0) {
1095             }
1096              
1097 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1098 0         0 $char = '\\' . $char;
1099             }
1100             }
1101              
1102             # [^...]
1103 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1104              
1105 0         0 $i = $left;
1106 0         0 last;
1107             }
1108             }
1109             }
1110              
1111             # rewrite classic character class or escape character
1112             elsif (my $char = classic_character_class($char[$i])) {
1113 0         0 $char[$i] = $char;
1114             }
1115              
1116             # with /i modifier
1117             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1118 0         0 my $uc = Elatin7::uc($char[$i]);
1119 0         0 my $fc = Elatin7::fc($char[$i]);
1120 0 0       0 if ($uc ne $fc) {
1121 0 0       0 if (CORE::length($fc) == 1) {
1122 0         0 $char[$i] = '[' . $uc . $fc . ']';
1123             }
1124             else {
1125 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1126             }
1127             }
1128             }
1129             }
1130              
1131             # characterize
1132 0         0 for (my $i=0; $i <= $#char; $i++) {
1133 0 0       0 next if not defined $char[$i];
1134              
1135 0 0       0 if (0) {
1136             }
1137              
1138             # quote character before ? + * {
1139 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1140 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1141 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1142             }
1143             }
1144             }
1145              
1146 0         0 $string = join '', @char;
1147             }
1148              
1149             # make regexp string
1150 0         0 return @string;
1151             }
1152              
1153             #
1154             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1155             #
1156             sub Elatin7::classic_character_class {
1157 1862     1862 0 1403 my($char) = @_;
1158              
1159             return {
1160             '\D' => '${Elatin7::eD}',
1161             '\S' => '${Elatin7::eS}',
1162             '\W' => '${Elatin7::eW}',
1163             '\d' => '[0-9]',
1164              
1165             # Before Perl 5.6, \s only matched the five whitespace characters
1166             # tab, newline, form-feed, carriage return, and the space character
1167             # itself, which, taken together, is the character class [\t\n\f\r ].
1168              
1169             # Vertical tabs are now whitespace
1170             # \s in a regex now matches a vertical tab in all circumstances.
1171             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1172             # \t \n \v \f \r space
1173             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1174             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1175             '\s' => '\s',
1176              
1177             '\w' => '[0-9A-Z_a-z]',
1178             '\C' => '[\x00-\xFF]',
1179             '\X' => 'X',
1180              
1181             # \h \v \H \V
1182              
1183             # P.114 Character Class Shortcuts
1184             # in Chapter 7: In the World of Regular Expressions
1185             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1186              
1187             # P.357 13.2.3 Whitespace
1188             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1189             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1190             #
1191             # 0x00009 CHARACTER TABULATION h s
1192             # 0x0000a LINE FEED (LF) vs
1193             # 0x0000b LINE TABULATION v
1194             # 0x0000c FORM FEED (FF) vs
1195             # 0x0000d CARRIAGE RETURN (CR) vs
1196             # 0x00020 SPACE h s
1197              
1198             # P.196 Table 5-9. Alphanumeric regex metasymbols
1199             # in Chapter 5. Pattern Matching
1200             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1201              
1202             # (and so on)
1203              
1204             '\H' => '${Elatin7::eH}',
1205             '\V' => '${Elatin7::eV}',
1206             '\h' => '[\x09\x20]',
1207             '\v' => '[\x0A\x0B\x0C\x0D]',
1208             '\R' => '${Elatin7::eR}',
1209              
1210             # \N
1211             #
1212             # http://perldoc.perl.org/perlre.html
1213             # Character Classes and other Special Escapes
1214             # Any character but \n (experimental). Not affected by /s modifier
1215              
1216             '\N' => '${Elatin7::eN}',
1217              
1218             # \b \B
1219              
1220             # P.180 Boundaries: The \b and \B Assertions
1221             # in Chapter 5: Pattern Matching
1222             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1223              
1224             # P.219 Boundaries: The \b and \B Assertions
1225             # in Chapter 5: Pattern Matching
1226             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1227              
1228             # \b really means (?:(?<=\w)(?!\w)|(?
1229             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1230             '\b' => '${Elatin7::eb}',
1231              
1232             # \B really means (?:(?<=\w)(?=\w)|(?
1233             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1234             '\B' => '${Elatin7::eB}',
1235              
1236 1862   100     62432 }->{$char} || '';
1237             }
1238              
1239             #
1240             # prepare Latin-7 characters per length
1241             #
1242              
1243             # 1 octet characters
1244             my @chars1 = ();
1245             sub chars1 {
1246 0 0   0 0 0 if (@chars1) {
1247 0         0 return @chars1;
1248             }
1249 0 0       0 if (exists $range_tr{1}) {
1250 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1251 0         0 while (my @range = splice(@ranges,0,1)) {
1252 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1253 0         0 push @chars1, pack 'C', $oct0;
1254             }
1255             }
1256             }
1257 0         0 return @chars1;
1258             }
1259              
1260             # 2 octets characters
1261             my @chars2 = ();
1262             sub chars2 {
1263 0 0   0 0 0 if (@chars2) {
1264 0         0 return @chars2;
1265             }
1266 0 0       0 if (exists $range_tr{2}) {
1267 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1268 0         0 while (my @range = splice(@ranges,0,2)) {
1269 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1270 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1271 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1272             }
1273             }
1274             }
1275             }
1276 0         0 return @chars2;
1277             }
1278              
1279             # 3 octets characters
1280             my @chars3 = ();
1281             sub chars3 {
1282 0 0   0 0 0 if (@chars3) {
1283 0         0 return @chars3;
1284             }
1285 0 0       0 if (exists $range_tr{3}) {
1286 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1287 0         0 while (my @range = splice(@ranges,0,3)) {
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 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1292             }
1293             }
1294             }
1295             }
1296             }
1297 0         0 return @chars3;
1298             }
1299              
1300             # 4 octets characters
1301             my @chars4 = ();
1302             sub chars4 {
1303 0 0   0 0 0 if (@chars4) {
1304 0         0 return @chars4;
1305             }
1306 0 0       0 if (exists $range_tr{4}) {
1307 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1308 0         0 while (my @range = splice(@ranges,0,4)) {
1309 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1310 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1311 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1312 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1313 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1314             }
1315             }
1316             }
1317             }
1318             }
1319             }
1320 0         0 return @chars4;
1321             }
1322              
1323             #
1324             # Latin-7 open character list for tr
1325             #
1326             sub _charlist_tr {
1327              
1328 0     0   0 local $_ = shift @_;
1329              
1330             # unescape character
1331 0         0 my @char = ();
1332 0         0 while (not /\G \z/oxmsgc) {
1333 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1334 0         0 push @char, '\-';
1335             }
1336             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1337 0         0 push @char, CORE::chr(oct $1);
1338             }
1339             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(hex $1);
1341             }
1342             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1343 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1344             }
1345             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1346             push @char, {
1347             '\0' => "\0",
1348             '\n' => "\n",
1349             '\r' => "\r",
1350             '\t' => "\t",
1351             '\f' => "\f",
1352             '\b' => "\x08", # \b means backspace in character class
1353             '\a' => "\a",
1354             '\e' => "\e",
1355 0         0 }->{$1};
1356             }
1357             elsif (/\G \\ ($q_char) /oxmsgc) {
1358 0         0 push @char, $1;
1359             }
1360             elsif (/\G ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             }
1364              
1365             # join separated multiple-octet
1366 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1367              
1368             # unescape '-'
1369 0         0 my @i = ();
1370 0         0 for my $i (0 .. $#char) {
1371 0 0       0 if ($char[$i] eq '\-') {
    0          
1372 0         0 $char[$i] = '-';
1373             }
1374             elsif ($char[$i] eq '-') {
1375 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1376 0         0 push @i, $i;
1377             }
1378             }
1379             }
1380              
1381             # open character list (reverse for splice)
1382 0         0 for my $i (CORE::reverse @i) {
1383 0         0 my @range = ();
1384              
1385             # range error
1386 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1387 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1388             }
1389              
1390             # range of multiple-octet code
1391 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1392 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1393 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1394             }
1395             elsif (CORE::length($char[$i+1]) == 2) {
1396 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1397 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1398             }
1399             elsif (CORE::length($char[$i+1]) == 3) {
1400 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1401 0         0 push @range, chars2();
1402 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1403             }
1404             elsif (CORE::length($char[$i+1]) == 4) {
1405 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1406 0         0 push @range, chars2();
1407 0         0 push @range, chars3();
1408 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1409             }
1410             else {
1411 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1412             }
1413             }
1414             elsif (CORE::length($char[$i-1]) == 2) {
1415 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1416 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1417             }
1418             elsif (CORE::length($char[$i+1]) == 3) {
1419 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1420 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1421             }
1422             elsif (CORE::length($char[$i+1]) == 4) {
1423 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1424 0         0 push @range, chars3();
1425 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1426             }
1427             else {
1428 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1429             }
1430             }
1431             elsif (CORE::length($char[$i-1]) == 3) {
1432 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1433 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1434             }
1435             elsif (CORE::length($char[$i+1]) == 4) {
1436 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1437 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1438             }
1439             else {
1440 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1441             }
1442             }
1443             elsif (CORE::length($char[$i-1]) == 4) {
1444 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1445 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1446             }
1447             else {
1448 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1449             }
1450             }
1451             else {
1452 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1453             }
1454              
1455 0         0 splice @char, $i-1, 3, @range;
1456             }
1457              
1458 0         0 return @char;
1459             }
1460              
1461             #
1462             # Latin-7 open character class
1463             #
1464             sub _cc {
1465 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1466 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1467             }
1468             elsif (scalar(@_) == 1) {
1469 0         0 return sprintf('\x%02X',$_[0]);
1470             }
1471             elsif (scalar(@_) == 2) {
1472 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1473 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1474             }
1475             elsif ($_[0] == $_[1]) {
1476 0         0 return sprintf('\x%02X',$_[0]);
1477             }
1478             elsif (($_[0]+1) == $_[1]) {
1479 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1480             }
1481             else {
1482 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1483             }
1484             }
1485             else {
1486 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1487             }
1488             }
1489              
1490             #
1491             # Latin-7 octet range
1492             #
1493             sub _octets {
1494 182     182   206 my $length = shift @_;
1495              
1496 182 50       248 if ($length == 1) {
1497 182         431 my($a1) = unpack 'C', $_[0];
1498 182         225 my($z1) = unpack 'C', $_[1];
1499              
1500 182 50       288 if ($a1 > $z1) {
1501 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1502             }
1503              
1504 182 50       365 if ($a1 == $z1) {
    50          
1505 0         0 return sprintf('\x%02X',$a1);
1506             }
1507             elsif (($a1+1) == $z1) {
1508 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1509             }
1510             else {
1511 182         1095 return sprintf('\x%02X-\x%02X',$a1,$z1);
1512             }
1513             }
1514             else {
1515 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1516             }
1517             }
1518              
1519             #
1520             # Latin-7 range regexp
1521             #
1522             sub _range_regexp {
1523 182     182   228 my($length,$first,$last) = @_;
1524              
1525 182         177 my @range_regexp = ();
1526 182 50       399 if (not exists $range_tr{$length}) {
1527 0         0 return @range_regexp;
1528             }
1529              
1530 182         148 my @ranges = @{ $range_tr{$length} };
  182         313  
1531 182         494 while (my @range = splice(@ranges,0,$length)) {
1532 182         166 my $min = '';
1533 182         141 my $max = '';
1534 182         352 for (my $i=0; $i < $length; $i++) {
1535 182         605 $min .= pack 'C', $range[$i][0];
1536 182         396 $max .= pack 'C', $range[$i][-1];
1537             }
1538              
1539             # min___max
1540             # FIRST_____________LAST
1541             # (nothing)
1542              
1543 182 50 33     1853 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1544             }
1545              
1546             # **********
1547             # min_________max
1548             # FIRST_____________LAST
1549             # **********
1550              
1551             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1552 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1553             }
1554              
1555             # **********************
1556             # min________________max
1557             # FIRST_____________LAST
1558             # **********************
1559              
1560             elsif (($min eq $first) and ($max eq $last)) {
1561 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1562             }
1563              
1564             # *********
1565             # min___max
1566             # FIRST_____________LAST
1567             # *********
1568              
1569             elsif (($first le $min) and ($max le $last)) {
1570 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1571             }
1572              
1573             # **********************
1574             # min__________________________max
1575             # FIRST_____________LAST
1576             # **********************
1577              
1578             elsif (($min le $first) and ($last le $max)) {
1579 182         341 push @range_regexp, _octets($length,$first,$last,$min,$max);
1580             }
1581              
1582             # *********
1583             # min________max
1584             # FIRST_____________LAST
1585             # *********
1586              
1587             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1588 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1589             }
1590              
1591             # min___max
1592             # FIRST_____________LAST
1593             # (nothing)
1594              
1595             elsif ($last lt $min) {
1596             }
1597              
1598             else {
1599 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1600             }
1601             }
1602              
1603 182         320 return @range_regexp;
1604             }
1605              
1606             #
1607             # Latin-7 open character list for qr and not qr
1608             #
1609             sub _charlist {
1610              
1611 358     358   435 my $modifier = pop @_;
1612 358         532 my @char = @_;
1613              
1614 358 100       598 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1615              
1616             # unescape character
1617 358         856 for (my $i=0; $i <= $#char; $i++) {
1618              
1619             # escape - to ...
1620 1125 100 100     8014 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1621 206 100 100     803 if ((0 < $i) and ($i < $#char)) {
1622 182         333 $char[$i] = '...';
1623             }
1624             }
1625              
1626             # octal escape sequence
1627             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1628 0         0 $char[$i] = octchr($1);
1629             }
1630              
1631             # hexadecimal escape sequence
1632             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1633 0         0 $char[$i] = hexchr($1);
1634             }
1635              
1636             # \b{...} --> b\{...}
1637             # \B{...} --> B\{...}
1638             # \N{CHARNAME} --> N\{CHARNAME}
1639             # \p{PROPERTY} --> p\{PROPERTY}
1640             # \P{PROPERTY} --> P\{PROPERTY}
1641             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1642 0         0 $char[$i] = $1 . '\\' . $2;
1643             }
1644              
1645             # \p, \P, \X --> p, P, X
1646             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1647 0         0 $char[$i] = $1;
1648             }
1649              
1650             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1651 0         0 $char[$i] = CORE::chr oct $1;
1652             }
1653             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1654 22         84 $char[$i] = CORE::chr hex $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1657 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1658             }
1659             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1660             $char[$i] = {
1661             '\0' => "\0",
1662             '\n' => "\n",
1663             '\r' => "\r",
1664             '\t' => "\t",
1665             '\f' => "\f",
1666             '\b' => "\x08", # \b means backspace in character class
1667             '\a' => "\a",
1668             '\e' => "\e",
1669             '\d' => '[0-9]',
1670              
1671             # Vertical tabs are now whitespace
1672             # \s in a regex now matches a vertical tab in all circumstances.
1673             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1674             # \t \n \v \f \r space
1675             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1676             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1677             '\s' => '\s',
1678              
1679             '\w' => '[0-9A-Z_a-z]',
1680             '\D' => '${Elatin7::eD}',
1681             '\S' => '${Elatin7::eS}',
1682             '\W' => '${Elatin7::eW}',
1683              
1684             '\H' => '${Elatin7::eH}',
1685             '\V' => '${Elatin7::eV}',
1686             '\h' => '[\x09\x20]',
1687             '\v' => '[\x0A\x0B\x0C\x0D]',
1688             '\R' => '${Elatin7::eR}',
1689              
1690 25         310 }->{$1};
1691             }
1692              
1693             # POSIX-style character classes
1694             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1695             $char[$i] = {
1696              
1697             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1698             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1699             '[:^lower:]' => '${Elatin7::not_lower_i}',
1700             '[:^upper:]' => '${Elatin7::not_upper_i}',
1701              
1702 8         48 }->{$1};
1703             }
1704             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1705             $char[$i] = {
1706              
1707             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1708             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1709             '[:ascii:]' => '[\x00-\x7F]',
1710             '[:blank:]' => '[\x09\x20]',
1711             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1712             '[:digit:]' => '[\x30-\x39]',
1713             '[:graph:]' => '[\x21-\x7F]',
1714             '[:lower:]' => '[\x61-\x7A]',
1715             '[:print:]' => '[\x20-\x7F]',
1716             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1717              
1718             # P.174 POSIX-Style Character Classes
1719             # in Chapter 5: Pattern Matching
1720             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1721              
1722             # P.311 11.2.4 Character Classes and other Special Escapes
1723             # in Chapter 11: perlre: Perl regular expressions
1724             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1725              
1726             # P.210 POSIX-Style Character Classes
1727             # in Chapter 5: Pattern Matching
1728             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1729              
1730             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1731              
1732             '[:upper:]' => '[\x41-\x5A]',
1733             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1734             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1735             '[:^alnum:]' => '${Elatin7::not_alnum}',
1736             '[:^alpha:]' => '${Elatin7::not_alpha}',
1737             '[:^ascii:]' => '${Elatin7::not_ascii}',
1738             '[:^blank:]' => '${Elatin7::not_blank}',
1739             '[:^cntrl:]' => '${Elatin7::not_cntrl}',
1740             '[:^digit:]' => '${Elatin7::not_digit}',
1741             '[:^graph:]' => '${Elatin7::not_graph}',
1742             '[:^lower:]' => '${Elatin7::not_lower}',
1743             '[:^print:]' => '${Elatin7::not_print}',
1744             '[:^punct:]' => '${Elatin7::not_punct}',
1745             '[:^space:]' => '${Elatin7::not_space}',
1746             '[:^upper:]' => '${Elatin7::not_upper}',
1747             '[:^word:]' => '${Elatin7::not_word}',
1748             '[:^xdigit:]' => '${Elatin7::not_xdigit}',
1749              
1750 70         1138 }->{$1};
1751             }
1752             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1753 7         29 $char[$i] = $1;
1754             }
1755             }
1756              
1757             # open character list
1758 358         435 my @singleoctet = ();
1759 358         345 my @multipleoctet = ();
1760 358         685 for (my $i=0; $i <= $#char; ) {
1761              
1762             # escaped -
1763 943 100 100     3666 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1764 182         153 $i += 1;
1765 182         324 next;
1766             }
1767              
1768             # make range regexp
1769             elsif ($char[$i] eq '...') {
1770              
1771             # range error
1772 182 50       583 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1773 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1774             }
1775             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1776 182 50       398 if ($char[$i-1] gt $char[$i+1]) {
1777 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]);
1778             }
1779             }
1780              
1781             # make range regexp per length
1782 182         449 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1783 182         188 my @regexp = ();
1784              
1785             # is first and last
1786 182 50 33     699 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1787 182         379 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1788             }
1789              
1790             # is first
1791             elsif ($length == CORE::length($char[$i-1])) {
1792 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1793             }
1794              
1795             # is inside in first and last
1796             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1797 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1798             }
1799              
1800             # is last
1801             elsif ($length == CORE::length($char[$i+1])) {
1802 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1803             }
1804              
1805             else {
1806 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1807             }
1808              
1809 182 50       324 if ($length == 1) {
1810 182         308 push @singleoctet, @regexp;
1811             }
1812             else {
1813 0         0 push @multipleoctet, @regexp;
1814             }
1815             }
1816              
1817 182         329 $i += 2;
1818             }
1819              
1820             # with /i modifier
1821             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1822 493 100       536 if ($modifier =~ /i/oxms) {
1823 24         34 my $uc = Elatin7::uc($char[$i]);
1824 24         42 my $fc = Elatin7::fc($char[$i]);
1825 24 100       33 if ($uc ne $fc) {
1826 12 50       17 if (CORE::length($fc) == 1) {
1827 12         15 push @singleoctet, $uc, $fc;
1828             }
1829             else {
1830 0         0 push @singleoctet, $uc;
1831 0         0 push @multipleoctet, $fc;
1832             }
1833             }
1834             else {
1835 12         17 push @singleoctet, $char[$i];
1836             }
1837             }
1838             else {
1839 469         479 push @singleoctet, $char[$i];
1840             }
1841 493         661 $i += 1;
1842             }
1843              
1844             # single character of single octet code
1845             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1846 0         0 push @singleoctet, "\t", "\x20";
1847 0         0 $i += 1;
1848             }
1849             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1850 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1851 0         0 $i += 1;
1852             }
1853             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1854 2         2 push @singleoctet, $char[$i];
1855 2         6 $i += 1;
1856             }
1857              
1858             # single character of multiple-octet code
1859             else {
1860 84         108 push @multipleoctet, $char[$i];
1861 84         135 $i += 1;
1862             }
1863             }
1864              
1865             # quote metachar
1866 358         583 for (@singleoctet) {
1867 689 50       2664 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1868 0         0 $_ = '-';
1869             }
1870             elsif (/\A \n \z/oxms) {
1871 8         14 $_ = '\n';
1872             }
1873             elsif (/\A \r \z/oxms) {
1874 8         13 $_ = '\r';
1875             }
1876             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1877 60         154 $_ = sprintf('\x%02X', CORE::ord $1);
1878             }
1879             elsif (/\A [\x00-\xFF] \z/oxms) {
1880 429         446 $_ = quotemeta $_;
1881             }
1882             }
1883              
1884             # return character list
1885 358         845 return \@singleoctet, \@multipleoctet;
1886             }
1887              
1888             #
1889             # Latin-7 octal escape sequence
1890             #
1891             sub octchr {
1892 5     5 0 7 my($octdigit) = @_;
1893              
1894 5         7 my @binary = ();
1895 5         15 for my $octal (split(//,$octdigit)) {
1896             push @binary, {
1897             '0' => '000',
1898             '1' => '001',
1899             '2' => '010',
1900             '3' => '011',
1901             '4' => '100',
1902             '5' => '101',
1903             '6' => '110',
1904             '7' => '111',
1905 50         140 }->{$octal};
1906             }
1907 5         10 my $binary = join '', @binary;
1908              
1909             my $octchr = {
1910             # 1234567
1911             1 => pack('B*', "0000000$binary"),
1912             2 => pack('B*', "000000$binary"),
1913             3 => pack('B*', "00000$binary"),
1914             4 => pack('B*', "0000$binary"),
1915             5 => pack('B*', "000$binary"),
1916             6 => pack('B*', "00$binary"),
1917             7 => pack('B*', "0$binary"),
1918             0 => pack('B*', "$binary"),
1919              
1920 5         58 }->{CORE::length($binary) % 8};
1921              
1922 5         16 return $octchr;
1923             }
1924              
1925             #
1926             # Latin-7 hexadecimal escape sequence
1927             #
1928             sub hexchr {
1929 5     5 0 9 my($hexdigit) = @_;
1930              
1931             my $hexchr = {
1932             1 => pack('H*', "0$hexdigit"),
1933             0 => pack('H*', "$hexdigit"),
1934              
1935 5         39 }->{CORE::length($_[0]) % 2};
1936              
1937 5         15 return $hexchr;
1938             }
1939              
1940             #
1941             # Latin-7 open character list for qr
1942             #
1943             sub charlist_qr {
1944              
1945 314     314 0 435 my $modifier = pop @_;
1946 314         558 my @char = @_;
1947              
1948 314         594 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1949 314         467 my @singleoctet = @$singleoctet;
1950 314         348 my @multipleoctet = @$multipleoctet;
1951              
1952             # return character list
1953 314 100       587 if (scalar(@singleoctet) >= 1) {
1954              
1955             # with /i modifier
1956 236 100       389 if ($modifier =~ m/i/oxms) {
1957 22         30 my %singleoctet_ignorecase = ();
1958 22         24 for (@singleoctet) {
1959 46   100     189 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1960 46         104 for my $ord (hex($1) .. hex($2)) {
1961 66         68 my $char = CORE::chr($ord);
1962 66         75 my $uc = Elatin7::uc($char);
1963 66         81 my $fc = Elatin7::fc($char);
1964 66 100       79 if ($uc eq $fc) {
1965 12         81 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1966             }
1967             else {
1968 54 50       65 if (CORE::length($fc) == 1) {
1969 54         89 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1970 54         175 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1971             }
1972             else {
1973 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1974 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1975             }
1976             }
1977             }
1978             }
1979 46 50       74 if ($_ ne '') {
1980 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1981             }
1982             }
1983 22         19 my $i = 0;
1984 22         18 my @singleoctet_ignorecase = ();
1985 22         31 for my $ord (0 .. 255) {
1986 5632 100       4744 if (exists $singleoctet_ignorecase{$ord}) {
1987 96         61 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         148  
1988             }
1989             else {
1990 5536         3474 $i++;
1991             }
1992             }
1993 22         31 @singleoctet = ();
1994 22         43 for my $range (@singleoctet_ignorecase) {
1995 3648 100       4790 if (ref $range) {
1996 56 100       33 if (scalar(@{$range}) == 1) {
  56 50       78  
1997 36         23 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         101  
1998             }
1999 20         21 elsif (scalar(@{$range}) == 2) {
2000 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2001             }
2002             else {
2003 20         19 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         17  
  20         75  
2004             }
2005             }
2006             }
2007             }
2008              
2009 236         265 my $not_anchor = '';
2010              
2011 236         471 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2012             }
2013 314 100       506 if (scalar(@multipleoctet) >= 2) {
2014 6         25 return '(?:' . join('|', @multipleoctet) . ')';
2015             }
2016             else {
2017 308         1045 return $multipleoctet[0];
2018             }
2019             }
2020              
2021             #
2022             # Latin-7 open character list for not qr
2023             #
2024             sub charlist_not_qr {
2025              
2026 44     44 0 77 my $modifier = pop @_;
2027 44         86 my @char = @_;
2028              
2029 44         105 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2030 44         73 my @singleoctet = @$singleoctet;
2031 44         48 my @multipleoctet = @$multipleoctet;
2032              
2033             # with /i modifier
2034 44 100       97 if ($modifier =~ m/i/oxms) {
2035 10         15 my %singleoctet_ignorecase = ();
2036 10         8 for (@singleoctet) {
2037 10   66     40 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2038 10         26 for my $ord (hex($1) .. hex($2)) {
2039 30         31 my $char = CORE::chr($ord);
2040 30         37 my $uc = Elatin7::uc($char);
2041 30         38 my $fc = Elatin7::fc($char);
2042 30 50       34 if ($uc eq $fc) {
2043 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2044             }
2045             else {
2046 30 50       35 if (CORE::length($fc) == 1) {
2047 30         51 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2048 30         79 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2049             }
2050             else {
2051 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2052 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2053             }
2054             }
2055             }
2056             }
2057 10 50       18 if ($_ ne '') {
2058 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2059             }
2060             }
2061 10         9 my $i = 0;
2062 10         10 my @singleoctet_ignorecase = ();
2063 10         11 for my $ord (0 .. 255) {
2064 2560 100       2457 if (exists $singleoctet_ignorecase{$ord}) {
2065 60         38 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         79  
2066             }
2067             else {
2068 2500         1584 $i++;
2069             }
2070             }
2071 10         13 @singleoctet = ();
2072 10         18 for my $range (@singleoctet_ignorecase) {
2073 960 100       1286 if (ref $range) {
2074 20 50       8 if (scalar(@{$range}) == 1) {
  20 50       29  
2075 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2076             }
2077 20         19 elsif (scalar(@{$range}) == 2) {
2078 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2079             }
2080             else {
2081 20         16 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         15  
  20         67  
2082             }
2083             }
2084             }
2085             }
2086              
2087             # return character list
2088 44 50       84 if (scalar(@multipleoctet) >= 1) {
2089 0 0       0 if (scalar(@singleoctet) >= 1) {
2090              
2091             # any character other than multiple-octet and single octet character class
2092 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2093             }
2094             else {
2095              
2096             # any character other than multiple-octet character class
2097 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2098             }
2099             }
2100             else {
2101 44 50       67 if (scalar(@singleoctet) >= 1) {
2102              
2103             # any character other than single octet character class
2104 44         209 return '(?:[^' . join('', @singleoctet) . '])';
2105             }
2106             else {
2107              
2108             # any character
2109 0         0 return "(?:$your_char)";
2110             }
2111             }
2112             }
2113              
2114             #
2115             # open file in read mode
2116             #
2117             sub _open_r {
2118 400     400   795 my(undef,$file) = @_;
2119 400         1658 $file =~ s#\A (\s) #./$1#oxms;
2120 400   33     25793 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2121             open($_[0],"< $file\0");
2122             }
2123              
2124             #
2125             # open file in write mode
2126             #
2127             sub _open_w {
2128 0     0   0 my(undef,$file) = @_;
2129 0         0 $file =~ s#\A (\s) #./$1#oxms;
2130 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2131             open($_[0],"> $file\0");
2132             }
2133              
2134             #
2135             # open file in append mode
2136             #
2137             sub _open_a {
2138 0     0   0 my(undef,$file) = @_;
2139 0         0 $file =~ s#\A (\s) #./$1#oxms;
2140 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2141             open($_[0],">> $file\0");
2142             }
2143              
2144             #
2145             # safe system
2146             #
2147             sub _systemx {
2148              
2149             # P.707 29.2.33. exec
2150             # in Chapter 29: Functions
2151             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2152             #
2153             # Be aware that in older releases of Perl, exec (and system) did not flush
2154             # your output buffer, so you needed to enable command buffering by setting $|
2155             # on one or more filehandles to avoid lost output in the case of exec, or
2156             # misordererd output in the case of system. This situation was largely remedied
2157             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2158              
2159             # P.855 exec
2160             # in Chapter 27: Functions
2161             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2162             #
2163             # In very old release of Perl (before v5.6), exec (and system) did not flush
2164             # your output buffer, so you needed to enable command buffering by setting $|
2165             # on one or more filehandles to avoid lost output with exec or misordered
2166             # output with system.
2167              
2168 200     200   603 $| = 1;
2169              
2170             # P.565 23.1.2. Cleaning Up Your Environment
2171             # in Chapter 23: Security
2172             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2173              
2174             # P.656 Cleaning Up Your Environment
2175             # in Chapter 20: Security
2176             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2177              
2178             # local $ENV{'PATH'} = '.';
2179 200         1404 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2180              
2181             # P.707 29.2.33. exec
2182             # in Chapter 29: Functions
2183             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2184             #
2185             # As we mentioned earlier, exec treats a discrete list of arguments as an
2186             # indication that it should bypass shell processing. However, there is one
2187             # place where you might still get tripped up. The exec call (and system, too)
2188             # will not distinguish between a single scalar argument and an array containing
2189             # only one element.
2190             #
2191             # @args = ("echo surprise"); # just one element in list
2192             # exec @args # still subject to shell escapes
2193             # or die "exec: $!"; # because @args == 1
2194             #
2195             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2196             # first argument as the pathname, which forces the rest of the arguments to be
2197             # interpreted as a list, even if there is only one of them:
2198             #
2199             # exec { $args[0] } @args # safe even with one-argument list
2200             # or die "can't exec @args: $!";
2201              
2202             # P.855 exec
2203             # in Chapter 27: Functions
2204             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2205             #
2206             # As we mentioned earlier, exec treats a discrete list of arguments as a
2207             # directive to bypass shell processing. However, there is one place where
2208             # you might still get tripped up. The exec call (and system, too) cannot
2209             # distinguish between a single scalar argument and an array containing
2210             # only one element.
2211             #
2212             # @args = ("echo surprise"); # just one element in list
2213             # exec @args # still subject to shell escapes
2214             # || die "exec: $!"; # because @args == 1
2215             #
2216             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2217             # argument as the pathname, which forces the rest of the arguments to be
2218             # interpreted as a list, even if there is only one of them:
2219             #
2220             # exec { $args[0] } @args # safe even with one-argument list
2221             # || die "can't exec @args: $!";
2222              
2223 200         281 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         12527055  
2224             }
2225              
2226             #
2227             # Latin-7 order to character (with parameter)
2228             #
2229             sub Elatin7::chr(;$) {
2230              
2231 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2232              
2233 0 0       0 if ($c == 0x00) {
2234 0         0 return "\x00";
2235             }
2236             else {
2237 0         0 my @chr = ();
2238 0         0 while ($c > 0) {
2239 0         0 unshift @chr, ($c % 0x100);
2240 0         0 $c = int($c / 0x100);
2241             }
2242 0         0 return pack 'C*', @chr;
2243             }
2244             }
2245              
2246             #
2247             # Latin-7 order to character (without parameter)
2248             #
2249             sub Elatin7::chr_() {
2250              
2251 0     0 0 0 my $c = $_;
2252              
2253 0 0       0 if ($c == 0x00) {
2254 0         0 return "\x00";
2255             }
2256             else {
2257 0         0 my @chr = ();
2258 0         0 while ($c > 0) {
2259 0         0 unshift @chr, ($c % 0x100);
2260 0         0 $c = int($c / 0x100);
2261             }
2262 0         0 return pack 'C*', @chr;
2263             }
2264             }
2265              
2266             #
2267             # Latin-7 path globbing (with parameter)
2268             #
2269             sub Elatin7::glob($) {
2270              
2271 0 0   0 0 0 if (wantarray) {
2272 0         0 my @glob = _DOS_like_glob(@_);
2273 0         0 for my $glob (@glob) {
2274 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2275             }
2276 0         0 return @glob;
2277             }
2278             else {
2279 0         0 my $glob = _DOS_like_glob(@_);
2280 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2281 0         0 return $glob;
2282             }
2283             }
2284              
2285             #
2286             # Latin-7 path globbing (without parameter)
2287             #
2288             sub Elatin7::glob_() {
2289              
2290 0 0   0 0 0 if (wantarray) {
2291 0         0 my @glob = _DOS_like_glob();
2292 0         0 for my $glob (@glob) {
2293 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2294             }
2295 0         0 return @glob;
2296             }
2297             else {
2298 0         0 my $glob = _DOS_like_glob();
2299 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2300 0         0 return $glob;
2301             }
2302             }
2303              
2304             #
2305             # Latin-7 path globbing via File::DosGlob 1.10
2306             #
2307             # Often I confuse "_dosglob" and "_doglob".
2308             # So, I renamed "_dosglob" to "_DOS_like_glob".
2309             #
2310             my %iter;
2311             my %entries;
2312             sub _DOS_like_glob {
2313              
2314             # context (keyed by second cxix argument provided by core)
2315 0     0   0 my($expr,$cxix) = @_;
2316              
2317             # glob without args defaults to $_
2318 0 0       0 $expr = $_ if not defined $expr;
2319              
2320             # represents the current user's home directory
2321             #
2322             # 7.3. Expanding Tildes in Filenames
2323             # in Chapter 7. File Access
2324             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2325             #
2326             # and File::HomeDir, File::HomeDir::Windows module
2327              
2328             # DOS-like system
2329 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2330 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2331 0         0 { my_home_MSWin32() }oxmse;
2332             }
2333              
2334             # UNIX-like system
2335             else {
2336 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2337 0 0 0     0 { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2338             }
2339              
2340             # assume global context if not provided one
2341 0 0       0 $cxix = '_G_' if not defined $cxix;
2342 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2343              
2344             # if we're just beginning, do it all first
2345 0 0       0 if ($iter{$cxix} == 0) {
2346 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2347             }
2348              
2349             # chuck it all out, quick or slow
2350 0 0       0 if (wantarray) {
2351 0         0 delete $iter{$cxix};
2352 0         0 return @{delete $entries{$cxix}};
  0         0  
2353             }
2354             else {
2355 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2356 0         0 return shift @{$entries{$cxix}};
  0         0  
2357             }
2358             else {
2359             # return undef for EOL
2360 0         0 delete $iter{$cxix};
2361 0         0 delete $entries{$cxix};
2362 0         0 return undef;
2363             }
2364             }
2365             }
2366              
2367             #
2368             # Latin-7 path globbing subroutine
2369             #
2370             sub _do_glob {
2371              
2372 0     0   0 my($cond,@expr) = @_;
2373 0         0 my @glob = ();
2374 0         0 my $fix_drive_relative_paths = 0;
2375              
2376             OUTER:
2377 0         0 for my $expr (@expr) {
2378 0 0       0 next OUTER if not defined $expr;
2379 0 0       0 next OUTER if $expr eq '';
2380              
2381 0         0 my @matched = ();
2382 0         0 my @globdir = ();
2383 0         0 my $head = '.';
2384 0         0 my $pathsep = '/';
2385 0         0 my $tail;
2386              
2387             # if argument is within quotes strip em and do no globbing
2388 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2389 0         0 $expr = $1;
2390 0 0       0 if ($cond eq 'd') {
2391 0 0       0 if (-d $expr) {
2392 0         0 push @glob, $expr;
2393             }
2394             }
2395             else {
2396 0 0       0 if (-e $expr) {
2397 0         0 push @glob, $expr;
2398             }
2399             }
2400 0         0 next OUTER;
2401             }
2402              
2403             # wildcards with a drive prefix such as h:*.pm must be changed
2404             # to h:./*.pm to expand correctly
2405 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2406 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2407 0         0 $fix_drive_relative_paths = 1;
2408             }
2409             }
2410              
2411 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2412 0 0       0 if ($tail eq '') {
2413 0         0 push @glob, $expr;
2414 0         0 next OUTER;
2415             }
2416 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2417 0 0       0 if (@globdir = _do_glob('d', $head)) {
2418 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2419 0         0 next OUTER;
2420             }
2421             }
2422 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2423 0         0 $head .= $pathsep;
2424             }
2425 0         0 $expr = $tail;
2426             }
2427              
2428             # If file component has no wildcards, we can avoid opendir
2429 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2430 0 0       0 if ($head eq '.') {
2431 0         0 $head = '';
2432             }
2433 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2434 0         0 $head .= $pathsep;
2435             }
2436 0         0 $head .= $expr;
2437 0 0       0 if ($cond eq 'd') {
2438 0 0       0 if (-d $head) {
2439 0         0 push @glob, $head;
2440             }
2441             }
2442             else {
2443 0 0       0 if (-e $head) {
2444 0         0 push @glob, $head;
2445             }
2446             }
2447 0         0 next OUTER;
2448             }
2449 0 0       0 opendir(*DIR, $head) or next OUTER;
2450 0         0 my @leaf = readdir DIR;
2451 0         0 closedir DIR;
2452              
2453 0 0       0 if ($head eq '.') {
2454 0         0 $head = '';
2455             }
2456 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2457 0         0 $head .= $pathsep;
2458             }
2459              
2460 0         0 my $pattern = '';
2461 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2462 0         0 my $char = $1;
2463              
2464             # 6.9. Matching Shell Globs as Regular Expressions
2465             # in Chapter 6. Pattern Matching
2466             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2467             # (and so on)
2468              
2469 0 0       0 if ($char eq '*') {
    0          
    0          
2470 0         0 $pattern .= "(?:$your_char)*",
2471             }
2472             elsif ($char eq '?') {
2473 0         0 $pattern .= "(?:$your_char)?", # DOS style
2474             # $pattern .= "(?:$your_char)", # UNIX style
2475             }
2476             elsif ((my $fc = Elatin7::fc($char)) ne $char) {
2477 0         0 $pattern .= $fc;
2478             }
2479             else {
2480 0         0 $pattern .= quotemeta $char;
2481             }
2482             }
2483 0     0   0 my $matchsub = sub { Elatin7::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2484              
2485             # if ($@) {
2486             # print STDERR "$0: $@\n";
2487             # next OUTER;
2488             # }
2489              
2490             INNER:
2491 0         0 for my $leaf (@leaf) {
2492 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2493 0         0 next INNER;
2494             }
2495 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2496 0         0 next INNER;
2497             }
2498              
2499 0 0       0 if (&$matchsub($leaf)) {
2500 0         0 push @matched, "$head$leaf";
2501 0         0 next INNER;
2502             }
2503              
2504             # [DOS compatibility special case]
2505             # Failed, add a trailing dot and try again, but only...
2506              
2507 0 0 0     0 if (Elatin7::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2508             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2509             Elatin7::index($pattern,'\\.') != -1 # pattern has a dot.
2510             ) {
2511 0 0       0 if (&$matchsub("$leaf.")) {
2512 0         0 push @matched, "$head$leaf";
2513 0         0 next INNER;
2514             }
2515             }
2516             }
2517 0 0       0 if (@matched) {
2518 0         0 push @glob, @matched;
2519             }
2520             }
2521 0 0       0 if ($fix_drive_relative_paths) {
2522 0         0 for my $glob (@glob) {
2523 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2524             }
2525             }
2526 0         0 return @glob;
2527             }
2528              
2529             #
2530             # Latin-7 parse line
2531             #
2532             sub _parse_line {
2533              
2534 0     0   0 my($line) = @_;
2535              
2536 0         0 $line .= ' ';
2537 0         0 my @piece = ();
2538 0         0 while ($line =~ /
2539             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2540             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2541             /oxmsg
2542             ) {
2543 0 0       0 push @piece, defined($1) ? $1 : $2;
2544             }
2545 0         0 return @piece;
2546             }
2547              
2548             #
2549             # Latin-7 parse path
2550             #
2551             sub _parse_path {
2552              
2553 0     0   0 my($path,$pathsep) = @_;
2554              
2555 0         0 $path .= '/';
2556 0         0 my @subpath = ();
2557 0         0 while ($path =~ /
2558             ((?: [^\/\\] )+?) [\/\\]
2559             /oxmsg
2560             ) {
2561 0         0 push @subpath, $1;
2562             }
2563              
2564 0         0 my $tail = pop @subpath;
2565 0         0 my $head = join $pathsep, @subpath;
2566 0         0 return $head, $tail;
2567             }
2568              
2569             #
2570             # via File::HomeDir::Windows 1.00
2571             #
2572             sub my_home_MSWin32 {
2573              
2574             # A lot of unix people and unix-derived tools rely on
2575             # the ability to overload HOME. We will support it too
2576             # so that they can replace raw HOME calls with File::HomeDir.
2577 0 0 0 0 0 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2578 0         0 return $ENV{'HOME'};
2579             }
2580              
2581             # Do we have a user profile?
2582             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2583 0         0 return $ENV{'USERPROFILE'};
2584             }
2585              
2586             # Some Windows use something like $ENV{'HOME'}
2587             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2588 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2589             }
2590              
2591 0         0 return undef;
2592             }
2593              
2594             #
2595             # via File::HomeDir::Unix 1.00
2596             #
2597             sub my_home {
2598 0     0 0 0 my $home;
2599              
2600 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2601 0         0 $home = $ENV{'HOME'};
2602             }
2603              
2604             # This is from the original code, but I'm guessing
2605             # it means "login directory" and exists on some Unixes.
2606             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2607 0         0 $home = $ENV{'LOGDIR'};
2608             }
2609              
2610             ### More-desperate methods
2611              
2612             # Light desperation on any (Unixish) platform
2613             else {
2614 0         0 $home = CORE::eval q{ (getpwuid($<))[7] };
2615             }
2616              
2617             # On Unix in general, a non-existant home means "no home"
2618             # For example, "nobody"-like users might use /nonexistant
2619 0 0 0     0 if (defined $home and ! -d($home)) {
2620 0         0 $home = undef;
2621             }
2622 0         0 return $home;
2623             }
2624              
2625             #
2626             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2627             #
2628             sub Elatin7::PREMATCH {
2629 0     0 0 0 return $`;
2630             }
2631              
2632             #
2633             # ${^MATCH}, $MATCH, $& the string that matched
2634             #
2635             sub Elatin7::MATCH {
2636 0     0 0 0 return $&;
2637             }
2638              
2639             #
2640             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2641             #
2642             sub Elatin7::POSTMATCH {
2643 0     0 0 0 return $';
2644             }
2645              
2646             #
2647             # Latin-7 character to order (with parameter)
2648             #
2649             sub Latin7::ord(;$) {
2650              
2651 0 0   0 1 0 local $_ = shift if @_;
2652              
2653 0 0       0 if (/\A ($q_char) /oxms) {
2654 0         0 my @ord = unpack 'C*', $1;
2655 0         0 my $ord = 0;
2656 0         0 while (my $o = shift @ord) {
2657 0         0 $ord = $ord * 0x100 + $o;
2658             }
2659 0         0 return $ord;
2660             }
2661             else {
2662 0         0 return CORE::ord $_;
2663             }
2664             }
2665              
2666             #
2667             # Latin-7 character to order (without parameter)
2668             #
2669             sub Latin7::ord_() {
2670              
2671 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2672 0         0 my @ord = unpack 'C*', $1;
2673 0         0 my $ord = 0;
2674 0         0 while (my $o = shift @ord) {
2675 0         0 $ord = $ord * 0x100 + $o;
2676             }
2677 0         0 return $ord;
2678             }
2679             else {
2680 0         0 return CORE::ord $_;
2681             }
2682             }
2683              
2684             #
2685             # Latin-7 reverse
2686             #
2687             sub Latin7::reverse(@) {
2688              
2689 0 0   0 0 0 if (wantarray) {
2690 0         0 return CORE::reverse @_;
2691             }
2692             else {
2693              
2694             # One of us once cornered Larry in an elevator and asked him what
2695             # problem he was solving with this, but he looked as far off into
2696             # the distance as he could in an elevator and said, "It seemed like
2697             # a good idea at the time."
2698              
2699 0         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2700             }
2701             }
2702              
2703             #
2704             # Latin-7 getc (with parameter, without parameter)
2705             #
2706             sub Latin7::getc(;*@) {
2707              
2708 0     0 0 0 my($package) = caller;
2709 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2710 0 0 0     0 croak 'Too many arguments for Latin7::getc' if @_ and not wantarray;
2711              
2712 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2713 0         0 my $getc = '';
2714 0         0 for my $length ($length[0] .. $length[-1]) {
2715 0         0 $getc .= CORE::getc($fh);
2716 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2717 0 0       0 if ($getc =~ /\A ${Elatin7::dot_s} \z/oxms) {
2718 0 0       0 return wantarray ? ($getc,@_) : $getc;
2719             }
2720             }
2721             }
2722 0 0       0 return wantarray ? ($getc,@_) : $getc;
2723             }
2724              
2725             #
2726             # Latin-7 length by character
2727             #
2728             sub Latin7::length(;$) {
2729              
2730 0 0   0 1 0 local $_ = shift if @_;
2731              
2732 0         0 local @_ = /\G ($q_char) /oxmsg;
2733 0         0 return scalar @_;
2734             }
2735              
2736             #
2737             # Latin-7 substr by character
2738             #
2739             BEGIN {
2740              
2741             # P.232 The lvalue Attribute
2742             # in Chapter 6: Subroutines
2743             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2744              
2745             # P.336 The lvalue Attribute
2746             # in Chapter 7: Subroutines
2747             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2748              
2749             # P.144 8.4 Lvalue subroutines
2750             # in Chapter 8: perlsub: Perl subroutines
2751             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2752              
2753 200 50 0 200 1 88092 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         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2754             # vv----------------------*******
2755             sub Latin7::substr($$;$$) %s {
2756              
2757             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2758              
2759             # If the substring is beyond either end of the string, substr() returns the undefined
2760             # value and produces a warning. When used as an lvalue, specifying a substring that
2761             # is entirely outside the string raises an exception.
2762             # http://perldoc.perl.org/functions/substr.html
2763              
2764             # A return with no argument returns the scalar value undef in scalar context,
2765             # an empty list () in list context, and (naturally) nothing at all in void
2766             # context.
2767              
2768             my $offset = $_[1];
2769             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2770             return;
2771             }
2772              
2773             # substr($string,$offset,$length,$replacement)
2774             if (@_ == 4) {
2775             my(undef,undef,$length,$replacement) = @_;
2776             my $substr = join '', splice(@char, $offset, $length, $replacement);
2777             $_[0] = join '', @char;
2778              
2779             # return $substr; this doesn't work, don't say "return"
2780             $substr;
2781             }
2782              
2783             # substr($string,$offset,$length)
2784             elsif (@_ == 3) {
2785             my(undef,undef,$length) = @_;
2786             my $octet_offset = 0;
2787             my $octet_length = 0;
2788             if ($offset == 0) {
2789             $octet_offset = 0;
2790             }
2791             elsif ($offset > 0) {
2792             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2793             }
2794             else {
2795             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2796             }
2797             if ($length == 0) {
2798             $octet_length = 0;
2799             }
2800             elsif ($length > 0) {
2801             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2802             }
2803             else {
2804             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2805             }
2806             CORE::substr($_[0], $octet_offset, $octet_length);
2807             }
2808              
2809             # substr($string,$offset)
2810             else {
2811             my $octet_offset = 0;
2812             if ($offset == 0) {
2813             $octet_offset = 0;
2814             }
2815             elsif ($offset > 0) {
2816             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2817             }
2818             else {
2819             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2820             }
2821             CORE::substr($_[0], $octet_offset);
2822             }
2823             }
2824             END
2825             }
2826              
2827             #
2828             # Latin-7 index by character
2829             #
2830             sub Latin7::index($$;$) {
2831              
2832 0     0 1 0 my $index;
2833 0 0       0 if (@_ == 3) {
2834 0         0 $index = Elatin7::index($_[0], $_[1], CORE::length(Latin7::substr($_[0], 0, $_[2])));
2835             }
2836             else {
2837 0         0 $index = Elatin7::index($_[0], $_[1]);
2838             }
2839              
2840 0 0       0 if ($index == -1) {
2841 0         0 return -1;
2842             }
2843             else {
2844 0         0 return Latin7::length(CORE::substr $_[0], 0, $index);
2845             }
2846             }
2847              
2848             #
2849             # Latin-7 rindex by character
2850             #
2851             sub Latin7::rindex($$;$) {
2852              
2853 0     0 1 0 my $rindex;
2854 0 0       0 if (@_ == 3) {
2855 0         0 $rindex = Elatin7::rindex($_[0], $_[1], CORE::length(Latin7::substr($_[0], 0, $_[2])));
2856             }
2857             else {
2858 0         0 $rindex = Elatin7::rindex($_[0], $_[1]);
2859             }
2860              
2861 0 0       0 if ($rindex == -1) {
2862 0         0 return -1;
2863             }
2864             else {
2865 0         0 return Latin7::length(CORE::substr $_[0], 0, $rindex);
2866             }
2867             }
2868              
2869             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2870             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2871 200     200   11978 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1138  
  200         267  
  200         9994  
2872              
2873             # ord() to ord() or Latin7::ord()
2874 200     200   9179 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   792  
  200         277  
  200         8293  
2875              
2876             # ord to ord or Latin7::ord_
2877 200     200   8883 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   766  
  200         255  
  200         8005  
2878              
2879             # reverse to reverse or Latin7::reverse
2880 200     200   8568 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   730  
  200         265  
  200         11328  
2881              
2882             # getc to getc or Latin7::getc
2883 200     200   8245 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   728  
  200         227  
  200         8646  
2884              
2885             # P.1023 Appendix W.9 Multibyte Anchoring
2886             # of ISBN 1-56592-224-7 CJKV Information Processing
2887              
2888             my $anchor = '';
2889              
2890 200     200   8504 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   746  
  200         256  
  200         6517983  
2891              
2892             # regexp of nested parens in qqXX
2893              
2894             # P.340 Matching Nested Constructs with Embedded Code
2895             # in Chapter 7: Perl
2896             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2897              
2898             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2899             [^\\()] |
2900             \( (?{$nest++}) |
2901             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2902             \\ [^c] |
2903             \\c[\x40-\x5F] |
2904             [\x00-\xFF]
2905             }xms;
2906              
2907             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2908             [^\\{}] |
2909             \{ (?{$nest++}) |
2910             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2911             \\ [^c] |
2912             \\c[\x40-\x5F] |
2913             [\x00-\xFF]
2914             }xms;
2915              
2916             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2917             [^\\\[\]] |
2918             \[ (?{$nest++}) |
2919             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2920             \\ [^c] |
2921             \\c[\x40-\x5F] |
2922             [\x00-\xFF]
2923             }xms;
2924              
2925             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2926             [^\\<>] |
2927             \< (?{$nest++}) |
2928             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2929             \\ [^c] |
2930             \\c[\x40-\x5F] |
2931             [\x00-\xFF]
2932             }xms;
2933              
2934             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2935             (?: ::)? (?:
2936             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2937             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2938             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2939             ))
2940             }xms;
2941              
2942             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2943             (?: ::)? (?:
2944             (?>[0-9]+) |
2945             [^a-zA-Z_0-9\[\]] |
2946             ^[A-Z] |
2947             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2948             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2949             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2950             ))
2951             }xms;
2952              
2953             my $qq_substr = qr{(?> Char::substr | Latin7::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2954             }xms;
2955              
2956             # regexp of nested parens in qXX
2957             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2958             [^()] |
2959             \( (?{$nest++}) |
2960             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2961             [\x00-\xFF]
2962             }xms;
2963              
2964             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2965             [^\{\}] |
2966             \{ (?{$nest++}) |
2967             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2968             [\x00-\xFF]
2969             }xms;
2970              
2971             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2972             [^\[\]] |
2973             \[ (?{$nest++}) |
2974             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2975             [\x00-\xFF]
2976             }xms;
2977              
2978             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2979             [^<>] |
2980             \< (?{$nest++}) |
2981             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2982             [\x00-\xFF]
2983             }xms;
2984              
2985             my $matched = '';
2986             my $s_matched = '';
2987              
2988             my $tr_variable = ''; # variable of tr///
2989             my $sub_variable = ''; # variable of s///
2990             my $bind_operator = ''; # =~ or !~
2991              
2992             my @heredoc = (); # here document
2993             my @heredoc_delimiter = ();
2994             my $here_script = ''; # here script
2995              
2996             #
2997             # escape Latin-7 script
2998             #
2999             sub Latin7::escape(;$) {
3000 200 50   200 0 526 local($_) = $_[0] if @_;
3001              
3002             # P.359 The Study Function
3003             # in Chapter 7: Perl
3004             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3005              
3006 200         291 study $_; # Yes, I studied study yesterday.
3007              
3008             # while all script
3009              
3010             # 6.14. Matching from Where the Last Pattern Left Off
3011             # in Chapter 6. Pattern Matching
3012             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3013             # (and so on)
3014              
3015             # one member of Tag-team
3016             #
3017             # P.128 Start of match (or end of previous match): \G
3018             # P.130 Advanced Use of \G with Perl
3019             # in Chapter 3: Overview of Regular Expression Features and Flavors
3020             # P.255 Use leading anchors
3021             # P.256 Expose ^ and \G at the front expressions
3022             # in Chapter 6: Crafting an Efficient Expression
3023             # P.315 "Tag-team" matching with /gc
3024             # in Chapter 7: Perl
3025             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3026              
3027 200         258 my $e_script = '';
3028 200         679 while (not /\G \z/oxgc) { # member
3029 71784         76580 $e_script .= Latin7::escape_token();
3030             }
3031              
3032 200         1855 return $e_script;
3033             }
3034              
3035             #
3036             # escape Latin-7 token of script
3037             #
3038             sub Latin7::escape_token {
3039              
3040             # \n output here document
3041              
3042 71784     71784 0 52887 my $ignore_modules = join('|', qw(
3043             utf8
3044             bytes
3045             charnames
3046             I18N::Japanese
3047             I18N::Collate
3048             I18N::JExt
3049             File::DosGlob
3050             Wild
3051             Wildcard
3052             Japanese
3053             ));
3054              
3055             # another member of Tag-team
3056             #
3057             # P.315 "Tag-team" matching with /gc
3058             # in Chapter 7: Perl
3059             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3060              
3061 71784 100 100     3266006 if (/\G ( \n ) /oxgc) { # another member (and so on)
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3062 12064         8940 my $heredoc = '';
3063 12064 100       17760 if (scalar(@heredoc_delimiter) >= 1) {
3064 150         120 $slash = 'm//';
3065              
3066 150         210 $heredoc = join '', @heredoc;
3067 150         201 @heredoc = ();
3068              
3069             # skip here document
3070 150         217 for my $heredoc_delimiter (@heredoc_delimiter) {
3071 150         847 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3072             }
3073 150         167 @heredoc_delimiter = ();
3074              
3075 150         138 $here_script = '';
3076             }
3077 12064         27853 return "\n" . $heredoc;
3078             }
3079              
3080             # ignore space, comment
3081 17217         39175 elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3082              
3083             # if (, elsif (, unless (, while (, until (, given (, and when (
3084              
3085             # given, when
3086              
3087             # P.225 The given Statement
3088             # in Chapter 15: Smart Matching and given-when
3089             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3090              
3091             # P.133 The given Statement
3092             # in Chapter 4: Statements and Declarations
3093             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3094              
3095             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3096 1373         1370 $slash = 'm//';
3097 1373         3340 return $1;
3098             }
3099              
3100             # scalar variable ($scalar = ...) =~ tr///;
3101             # scalar variable ($scalar = ...) =~ s///;
3102              
3103             # state
3104              
3105             # P.68 Persistent, Private Variables
3106             # in Chapter 4: Subroutines
3107             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3108              
3109             # P.160 Persistent Lexically Scoped Variables: state
3110             # in Chapter 4: Statements and Declarations
3111             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3112              
3113             # (and so on)
3114              
3115             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3116 85         139 my $e_string = e_string($1);
3117              
3118 85 50       1861 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3119 0         0 $tr_variable = $e_string . e_string($1);
3120 0         0 $bind_operator = $2;
3121 0         0 $slash = 'm//';
3122 0         0 return '';
3123             }
3124             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3125 0         0 $sub_variable = $e_string . e_string($1);
3126 0         0 $bind_operator = $2;
3127 0         0 $slash = 'm//';
3128 0         0 return '';
3129             }
3130             else {
3131 85         84 $slash = 'div';
3132 85         242 return $e_string;
3133             }
3134             }
3135              
3136             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
3137             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3138 4         5 $slash = 'div';
3139 4         14 return q{Elatin7::PREMATCH()};
3140             }
3141              
3142             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
3143             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3144 28         37 $slash = 'div';
3145 28         70 return q{Elatin7::MATCH()};
3146             }
3147              
3148             # $', ${'} --> $', ${'}
3149             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3150 1         2 $slash = 'div';
3151 1         4 return $1;
3152             }
3153              
3154             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
3155             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3156 3         7 $slash = 'div';
3157 3         15 return q{Elatin7::POSTMATCH()};
3158             }
3159              
3160             # scalar variable $scalar =~ tr///;
3161             # scalar variable $scalar =~ s///;
3162             # substr() =~ tr///;
3163             # substr() =~ s///;
3164             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3165 1604         2425 my $scalar = e_string($1);
3166              
3167 1604 100       5011 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3168 1         2 $tr_variable = $scalar;
3169 1         2 $bind_operator = $1;
3170 1         1 $slash = 'm//';
3171 1         2 return '';
3172             }
3173             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3174 61         86 $sub_variable = $scalar;
3175 61         93 $bind_operator = $1;
3176 61         60 $slash = 'm//';
3177 61         169 return '';
3178             }
3179             else {
3180 1542         1381 $slash = 'div';
3181 1542         3436 return $scalar;
3182             }
3183             }
3184              
3185             # end of statement
3186             elsif (/\G ( [,;] ) /oxgc) {
3187 4559         4240 $slash = 'm//';
3188              
3189             # clear tr/// variable
3190 4559         3492 $tr_variable = '';
3191              
3192             # clear s/// variable
3193 4559         3263 $sub_variable = '';
3194              
3195 4559         3121 $bind_operator = '';
3196              
3197 4559         12104 return $1;
3198             }
3199              
3200             # bareword
3201             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3202 0         0 return $1;
3203             }
3204              
3205             # $0 --> $0
3206             elsif (/\G ( \$ 0 ) /oxmsgc) {
3207 2         3 $slash = 'div';
3208 2         7 return $1;
3209             }
3210             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3211 0         0 $slash = 'div';
3212 0         0 return $1;
3213             }
3214              
3215             # $$ --> $$
3216             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3217 1         3 $slash = 'div';
3218 1         5 return $1;
3219             }
3220              
3221             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3222             # $1, $2, $3 --> $1, $2, $3 otherwise
3223             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3224 4         4 $slash = 'div';
3225 4         6 return e_capture($1);
3226             }
3227             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3228 0         0 $slash = 'div';
3229 0         0 return e_capture($1);
3230             }
3231              
3232             # $$foo[ ... ] --> $ $foo->[ ... ]
3233             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3234 0         0 $slash = 'div';
3235 0         0 return e_capture($1.'->'.$2);
3236             }
3237              
3238             # $$foo{ ... } --> $ $foo->{ ... }
3239             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3240 0         0 $slash = 'div';
3241 0         0 return e_capture($1.'->'.$2);
3242             }
3243              
3244             # $$foo
3245             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3246 0         0 $slash = 'div';
3247 0         0 return e_capture($1);
3248             }
3249              
3250             # ${ foo }
3251             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3252 0         0 $slash = 'div';
3253 0         0 return '${' . $1 . '}';
3254             }
3255              
3256             # ${ ... }
3257             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3258 0         0 $slash = 'div';
3259 0         0 return e_capture($1);
3260             }
3261              
3262             # variable or function
3263             # $ @ % & * $ #
3264             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) {
3265 42         48 $slash = 'div';
3266 42         133 return $1;
3267             }
3268             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3269             # $ @ # \ ' " / ? ( ) [ ] < >
3270             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3271 60         82 $slash = 'div';
3272 60         186 return $1;
3273             }
3274              
3275             # while ()
3276             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3277 0         0 return $1;
3278             }
3279              
3280             # while () --- glob
3281              
3282             # avoid "Error: Runtime exception" of perl version 5.005_03
3283              
3284             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3285 0         0 return 'while ($_ = Elatin7::glob("' . $1 . '"))';
3286             }
3287              
3288             # while (glob)
3289             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3290 0         0 return 'while ($_ = Elatin7::glob_)';
3291             }
3292              
3293             # while (glob(WILDCARD))
3294             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3295 0         0 return 'while ($_ = Elatin7::glob';
3296             }
3297              
3298             # doit if, doit unless, doit while, doit until, doit for, doit when
3299 241         378 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         710  
3300              
3301             # subroutines of package Elatin7
3302 19         21 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         53  
3303 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3304 13         12 elsif (/\G \b Latin7::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         32  
3305 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3306 114         101 elsif (/\G \b Latin7::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin7::escape'; }
  114         260  
3307 2         3 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3308 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::chop'; }
  0         0  
3309 2         4 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
3310 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3311 0         0 elsif (/\G \b Latin7::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin7::index'; }
  0         0  
3312 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::index'; }
  0         0  
3313 2         3 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         6  
3314 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3315 0         0 elsif (/\G \b Latin7::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin7::rindex'; }
  0         0  
3316 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::rindex'; }
  0         0  
3317 1         2 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::lc'; }
  1         4  
3318 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::lcfirst'; }
  0         0  
3319 1         1 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::uc'; }
  1         4  
3320 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::ucfirst'; }
  0         0  
3321 6         7 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::fc'; }
  6         13  
3322              
3323             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3324 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3325 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3326 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3327 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3328 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3329 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3330 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3331              
3332 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3333 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3334 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3335 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3336 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3337 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3338 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3339              
3340             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3341 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3342 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3343 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3344 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3345              
3346 2         4 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         5  
3347 2         3 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3348 36         40 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::chr'; }
  36         97  
3349 2         3 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         6  
3350 8         11 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         19  
3351 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::glob'; }
  0         0  
3352 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::lc_'; }
  0         0  
3353 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::lcfirst_'; }
  0         0  
3354 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::uc_'; }
  0         0  
3355 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::ucfirst_'; }
  0         0  
3356 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::fc_'; }
  0         0  
3357 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3358              
3359 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3360 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3361 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::chr_'; }
  0         0  
3362 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3363 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3364 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::glob_'; }
  0         0  
3365 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3366 8         15 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         42  
3367             # split
3368             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3369 87         113 $slash = 'm//';
3370              
3371 87         92 my $e = '';
3372 87         280 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3373 85         278 $e .= $1;
3374             }
3375              
3376             # end of split
3377 87 100       6632 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin7::split' . $e; }
  2 100       8  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3378              
3379             # split scalar value
3380 1         3 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin7::split' . $e . e_string($1); }
3381              
3382             # split literal space
3383 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin7::split' . $e . qq {qq$1 $2}; }
3384 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3385 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3386 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3387 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3388 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3389 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin7::split' . $e . qq {q$1 $2}; }
3390 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3391 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3392 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3393 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3394 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3395 10         38 elsif (/\G ' [ ] ' /oxgc) { return 'Elatin7::split' . $e . qq {' '}; }
3396 0         0 elsif (/\G " [ ] " /oxgc) { return 'Elatin7::split' . $e . qq {" "}; }
3397              
3398             # split qq//
3399             elsif (/\G \b (qq) \b /oxgc) {
3400 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3401             else {
3402 0         0 while (not /\G \z/oxgc) {
3403 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3404 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3405 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3406 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3407 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3408 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3409 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3410             }
3411 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3412             }
3413             }
3414              
3415             # split qr//
3416             elsif (/\G \b (qr) \b /oxgc) {
3417 12 50       410 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3418             else {
3419 12         52 while (not /\G \z/oxgc) {
3420 12 50       2894 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3421 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3422 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3423 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3424 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3425 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3426 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3427 12         60 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3428             }
3429 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3430             }
3431             }
3432              
3433             # split q//
3434             elsif (/\G \b (q) \b /oxgc) {
3435 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3436             else {
3437 0         0 while (not /\G \z/oxgc) {
3438 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3439 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3440 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3441 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3442 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3443 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3444 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3445             }
3446 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3447             }
3448             }
3449              
3450             # split m//
3451             elsif (/\G \b (m) \b /oxgc) {
3452 18 50       459 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3453             else {
3454 18         70 while (not /\G \z/oxgc) {
3455 18 50       3351 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3456 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3457 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3458 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3459 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3460 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3461 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3462 18         73 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3463             }
3464 0         0 die __FILE__, ": Search pattern not terminated\n";
3465             }
3466             }
3467              
3468             # split ''
3469             elsif (/\G (\') /oxgc) {
3470 0         0 my $q_string = '';
3471 0         0 while (not /\G \z/oxgc) {
3472 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3473 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3474 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3475 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3476             }
3477 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3478             }
3479              
3480             # split ""
3481             elsif (/\G (\") /oxgc) {
3482 0         0 my $qq_string = '';
3483 0         0 while (not /\G \z/oxgc) {
3484 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3485 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3486 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3487 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3488             }
3489 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3490             }
3491              
3492             # split //
3493             elsif (/\G (\/) /oxgc) {
3494 44         64 my $regexp = '';
3495 44         122 while (not /\G \z/oxgc) {
3496 381 50       1362 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3497 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3498 44         160 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3499 337         565 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3500             }
3501 0         0 die __FILE__, ": Search pattern not terminated\n";
3502             }
3503             }
3504              
3505             # tr/// or y///
3506              
3507             # about [cdsrbB]* (/B modifier)
3508             #
3509             # P.559 appendix C
3510             # of ISBN 4-89052-384-7 Programming perl
3511             # (Japanese title is: Perl puroguramingu)
3512              
3513             elsif (/\G \b ( tr | y ) \b /oxgc) {
3514 3         4 my $ope = $1;
3515              
3516             # $1 $2 $3 $4 $5 $6
3517 3 50       40 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3518 0         0 my @tr = ($tr_variable,$2);
3519 0         0 return e_tr(@tr,'',$4,$6);
3520             }
3521             else {
3522 3         3 my $e = '';
3523 3         10 while (not /\G \z/oxgc) {
3524 3 50       190 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3525             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3526 0         0 my @tr = ($tr_variable,$2);
3527 0         0 while (not /\G \z/oxgc) {
3528 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3529 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3530 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3531 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3532 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3533 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3534             }
3535 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3536             }
3537             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3538 0         0 my @tr = ($tr_variable,$2);
3539 0         0 while (not /\G \z/oxgc) {
3540 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3541 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3542 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3543 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3544 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3545 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3546             }
3547 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3548             }
3549             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3550 0         0 my @tr = ($tr_variable,$2);
3551 0         0 while (not /\G \z/oxgc) {
3552 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3553 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3554 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3555 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3556 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3557 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3558             }
3559 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3560             }
3561             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3562 0         0 my @tr = ($tr_variable,$2);
3563 0         0 while (not /\G \z/oxgc) {
3564 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3565 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3566 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3567 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3568 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3569 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3570             }
3571 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3572             }
3573             # $1 $2 $3 $4 $5 $6
3574             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3575 3         9 my @tr = ($tr_variable,$2);
3576 3         7 return e_tr(@tr,'',$4,$6);
3577             }
3578             }
3579 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3580             }
3581             }
3582              
3583             # qq//
3584             elsif (/\G \b (qq) \b /oxgc) {
3585 2130         2905 my $ope = $1;
3586              
3587             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3588 2130 50       2801 if (/\G (\#) /oxgc) { # qq# #
3589 0         0 my $qq_string = '';
3590 0         0 while (not /\G \z/oxgc) {
3591 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3592 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3593 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3594 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3595             }
3596 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3597             }
3598              
3599             else {
3600 2130         1795 my $e = '';
3601 2130         4058 while (not /\G \z/oxgc) {
3602 2130 50       6576 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3603              
3604             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3605             elsif (/\G (\() /oxgc) { # qq ( )
3606 0         0 my $qq_string = '';
3607 0         0 local $nest = 1;
3608 0         0 while (not /\G \z/oxgc) {
3609 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3610 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3611 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3612             elsif (/\G (\)) /oxgc) {
3613 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3614 0         0 else { $qq_string .= $1; }
3615             }
3616 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3617             }
3618 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3619             }
3620              
3621             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3622             elsif (/\G (\{) /oxgc) { # qq { }
3623 2100         1676 my $qq_string = '';
3624 2100         2087 local $nest = 1;
3625 2100         3460 while (not /\G \z/oxgc) {
3626 82644 100       232999 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1222  
    100          
    100          
    50          
3627 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3628 1103         999 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         1610  
3629             elsif (/\G (\}) /oxgc) {
3630 3203 100       3588 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         3272  
3631 1103         1910 else { $qq_string .= $1; }
3632             }
3633 77616         120223 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3634             }
3635 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3636             }
3637              
3638             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3639             elsif (/\G (\[) /oxgc) { # qq [ ]
3640 0         0 my $qq_string = '';
3641 0         0 local $nest = 1;
3642 0         0 while (not /\G \z/oxgc) {
3643 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3644 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3645 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3646             elsif (/\G (\]) /oxgc) {
3647 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3648 0         0 else { $qq_string .= $1; }
3649             }
3650 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3651             }
3652 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3653             }
3654              
3655             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3656             elsif (/\G (\<) /oxgc) { # qq < >
3657 30         28 my $qq_string = '';
3658 30         45 local $nest = 1;
3659 30         73 while (not /\G \z/oxgc) {
3660 1166 100       3685 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       45  
    50          
    100          
    50          
3661 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3662 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3663             elsif (/\G (\>) /oxgc) {
3664 30 50       50 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         56  
3665 0         0 else { $qq_string .= $1; }
3666             }
3667 1114         1805 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3668             }
3669 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3670             }
3671              
3672             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3673             elsif (/\G (\S) /oxgc) { # qq * *
3674 0         0 my $delimiter = $1;
3675 0         0 my $qq_string = '';
3676 0         0 while (not /\G \z/oxgc) {
3677 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3678 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3679 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3680 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3681             }
3682 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3683             }
3684             }
3685 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3686             }
3687             }
3688              
3689             # qr//
3690             elsif (/\G \b (qr) \b /oxgc) {
3691 0         0 my $ope = $1;
3692 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3693 0         0 return e_qr($ope,$1,$3,$2,$4);
3694             }
3695             else {
3696 0         0 my $e = '';
3697 0         0 while (not /\G \z/oxgc) {
3698 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3699 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3700 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3701 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3702 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3703 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3704 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3705 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3706             }
3707 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3708             }
3709             }
3710              
3711             # qw//
3712             elsif (/\G \b (qw) \b /oxgc) {
3713 16         42 my $ope = $1;
3714 16 50       66 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3715 0         0 return e_qw($ope,$1,$3,$2);
3716             }
3717             else {
3718 16         24 my $e = '';
3719 16         45 while (not /\G \z/oxgc) {
3720 16 50       110 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3721              
3722 16         48 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3723 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3724              
3725 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3726 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3727              
3728 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3729 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3730              
3731 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3732 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3733              
3734 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3735 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3736             }
3737 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3738             }
3739             }
3740              
3741             # qx//
3742             elsif (/\G \b (qx) \b /oxgc) {
3743 0         0 my $ope = $1;
3744 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3745 0         0 return e_qq($ope,$1,$3,$2);
3746             }
3747             else {
3748 0         0 my $e = '';
3749 0         0 while (not /\G \z/oxgc) {
3750 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3751 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3752 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3753 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3754 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3755 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3756 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3757             }
3758 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3759             }
3760             }
3761              
3762             # q//
3763             elsif (/\G \b (q) \b /oxgc) {
3764 245         496 my $ope = $1;
3765              
3766             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3767              
3768             # avoid "Error: Runtime exception" of perl version 5.005_03
3769             # (and so on)
3770              
3771 245 50       606 if (/\G (\#) /oxgc) { # q# #
3772 0         0 my $q_string = '';
3773 0         0 while (not /\G \z/oxgc) {
3774 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3775 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3776 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3777 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3778             }
3779 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3780             }
3781              
3782             else {
3783 245         327 my $e = '';
3784 245         696 while (not /\G \z/oxgc) {
3785 245 50       1286 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3786              
3787             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3788             elsif (/\G (\() /oxgc) { # q ( )
3789 0         0 my $q_string = '';
3790 0         0 local $nest = 1;
3791 0         0 while (not /\G \z/oxgc) {
3792 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3793 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3794 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3795 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3796             elsif (/\G (\)) /oxgc) {
3797 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3798 0         0 else { $q_string .= $1; }
3799             }
3800 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3801             }
3802 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3803             }
3804              
3805             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3806             elsif (/\G (\{) /oxgc) { # q { }
3807 239         301 my $q_string = '';
3808 239         367 local $nest = 1;
3809 239         657 while (not /\G \z/oxgc) {
3810 3637 50       14662 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3811 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3812 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3813 107         115 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         193  
3814             elsif (/\G (\}) /oxgc) {
3815 346 100       597 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         623  
3816 107         182 else { $q_string .= $1; }
3817             }
3818 3184         5492 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3819             }
3820 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3821             }
3822              
3823             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3824             elsif (/\G (\[) /oxgc) { # q [ ]
3825 0         0 my $q_string = '';
3826 0         0 local $nest = 1;
3827 0         0 while (not /\G \z/oxgc) {
3828 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3829 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3830 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3831 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3832             elsif (/\G (\]) /oxgc) {
3833 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3834 0         0 else { $q_string .= $1; }
3835             }
3836 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3837             }
3838 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3839             }
3840              
3841             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3842             elsif (/\G (\<) /oxgc) { # q < >
3843 5         8 my $q_string = '';
3844 5         5 local $nest = 1;
3845 5         47 while (not /\G \z/oxgc) {
3846 88 50       362 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3847 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3848 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3849 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3850             elsif (/\G (\>) /oxgc) {
3851 5 50       22 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         9  
3852 0         0 else { $q_string .= $1; }
3853             }
3854 83         131 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3855             }
3856 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3857             }
3858              
3859             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3860             elsif (/\G (\S) /oxgc) { # q * *
3861 1         2 my $delimiter = $1;
3862 1         2 my $q_string = '';
3863 1         5 while (not /\G \z/oxgc) {
3864 14 50       72 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3865 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3866 1         2 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3867 13         19 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3868             }
3869 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3870             }
3871             }
3872 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3873             }
3874             }
3875              
3876             # m//
3877             elsif (/\G \b (m) \b /oxgc) {
3878 209         314 my $ope = $1;
3879 209 50       1512 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3880 0         0 return e_qr($ope,$1,$3,$2,$4);
3881             }
3882             else {
3883 209         201 my $e = '';
3884 209         450 while (not /\G \z/oxgc) {
3885 209 50       10240 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3886 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3887 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3888 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3889 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3890 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3891 10         23 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3892 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3893 199         456 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3894             }
3895 0         0 die __FILE__, ": Search pattern not terminated\n";
3896             }
3897             }
3898              
3899             # s///
3900              
3901             # about [cegimosxpradlunbB]* (/cg modifier)
3902             #
3903             # P.67 Pattern-Matching Operators
3904             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3905              
3906             elsif (/\G \b (s) \b /oxgc) {
3907 97         170 my $ope = $1;
3908              
3909             # $1 $2 $3 $4 $5 $6
3910 97 100       1810 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3911 1         5 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3912             }
3913             else {
3914 96         121 my $e = '';
3915 96         246 while (not /\G \z/oxgc) {
3916 96 50       10013 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3917             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3918 0         0 my @s = ($1,$2,$3);
3919 0         0 while (not /\G \z/oxgc) {
3920 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3921             # $1 $2 $3 $4
3922 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3923 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931             }
3932 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3933             }
3934             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3935 0         0 my @s = ($1,$2,$3);
3936 0         0 while (not /\G \z/oxgc) {
3937 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3938             # $1 $2 $3 $4
3939 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948             }
3949 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3950             }
3951             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3952 0         0 my @s = ($1,$2,$3);
3953 0         0 while (not /\G \z/oxgc) {
3954 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3955             # $1 $2 $3 $4
3956 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963             }
3964 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3965             }
3966             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3967 0         0 my @s = ($1,$2,$3);
3968 0         0 while (not /\G \z/oxgc) {
3969 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3970             # $1 $2 $3 $4
3971 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980             }
3981 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3982             }
3983             # $1 $2 $3 $4 $5 $6
3984             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3985 21         43 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3986             }
3987             # $1 $2 $3 $4 $5 $6
3988             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3989 0         0 return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3990             }
3991             # $1 $2 $3 $4 $5 $6
3992             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3993 0         0 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3994             }
3995             # $1 $2 $3 $4 $5 $6
3996             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3997 75         239 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3998             }
3999             }
4000 0         0 die __FILE__, ": Substitution pattern not terminated\n";
4001             }
4002             }
4003              
4004             # require ignore module
4005 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4006 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4007 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4008              
4009             # use strict; --> use strict; no strict qw(refs);
4010 36         250 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4011 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4012 0         0 elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4013              
4014             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4015             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4016 2 50 33     24 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4017 0         0 return "use $1; no strict qw(refs);";
4018             }
4019             else {
4020 2         9 return "use $1;";
4021             }
4022             }
4023             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4024 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4025 0         0 return "use $1; no strict qw(refs);";
4026             }
4027             else {
4028 0         0 return "use $1;";
4029             }
4030             }
4031              
4032             # ignore use module
4033 2         15 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4034 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4035 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4036              
4037             # ignore no module
4038 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4039 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4040 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4041              
4042             # use else
4043 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4044              
4045             # use else
4046 2         7 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4047              
4048             # ''
4049             elsif (/\G (?
4050 841         965 my $q_string = '';
4051 841         1663 while (not /\G \z/oxgc) {
4052 8209 100       23332 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       9  
    100          
    50          
4053 48         83 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4054 841         1452 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4055 7316         13194 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4056             }
4057 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4058             }
4059              
4060             # ""
4061             elsif (/\G (\") /oxgc) {
4062 1741         1946 my $qq_string = '';
4063 1741         3439 while (not /\G \z/oxgc) {
4064 34294 100       86411 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       131  
    100          
    50          
4065 12         21 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4066 1741         3006 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4067 32474         50199 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4068             }
4069 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4070             }
4071              
4072             # ``
4073             elsif (/\G (\`) /oxgc) {
4074 1         1 my $qx_string = '';
4075 1         4 while (not /\G \z/oxgc) {
4076 19 50       71 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4077 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4078 1         3 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4079 18         27 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4080             }
4081 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4082             }
4083              
4084             # // --- not divide operator (num / num), not defined-or
4085             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4086 452         599 my $regexp = '';
4087 452         1011 while (not /\G \z/oxgc) {
4088 4490 50       13579 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4089 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4090 452         921 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4091 4038         6679 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4092             }
4093 0         0 die __FILE__, ": Search pattern not terminated\n";
4094             }
4095              
4096             # ?? --- not conditional operator (condition ? then : else)
4097             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4098 0         0 my $regexp = '';
4099 0         0 while (not /\G \z/oxgc) {
4100 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4101 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4102 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4103 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4104             }
4105 0         0 die __FILE__, ": Search pattern not terminated\n";
4106             }
4107              
4108             # <<>> (a safer ARGV)
4109 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4110              
4111             # << (bit shift) --- not here document
4112 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4113              
4114             # <<'HEREDOC'
4115             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4116 72         73 $slash = 'm//';
4117 72         110 my $here_quote = $1;
4118 72         77 my $delimiter = $2;
4119              
4120             # get here document
4121 72 50       102 if ($here_script eq '') {
4122 72         281 $here_script = CORE::substr $_, pos $_;
4123 72         314 $here_script =~ s/.*?\n//oxm;
4124             }
4125 72 50       466 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4126 72         175 push @heredoc, $1 . qq{\n$delimiter\n};
4127 72         99 push @heredoc_delimiter, $delimiter;
4128             }
4129             else {
4130 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4131             }
4132 72         251 return $here_quote;
4133             }
4134              
4135             # <<\HEREDOC
4136              
4137             # P.66 2.6.6. "Here" Documents
4138             # in Chapter 2: Bits and Pieces
4139             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4140              
4141             # P.73 "Here" Documents
4142             # in Chapter 2: Bits and Pieces
4143             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4144              
4145             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4146 0         0 $slash = 'm//';
4147 0         0 my $here_quote = $1;
4148 0         0 my $delimiter = $2;
4149              
4150             # get here document
4151 0 0       0 if ($here_script eq '') {
4152 0         0 $here_script = CORE::substr $_, pos $_;
4153 0         0 $here_script =~ s/.*?\n//oxm;
4154             }
4155 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4156 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4157 0         0 push @heredoc_delimiter, $delimiter;
4158             }
4159             else {
4160 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4161             }
4162 0         0 return $here_quote;
4163             }
4164              
4165             # <<"HEREDOC"
4166             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4167 36         57 $slash = 'm//';
4168 36         62 my $here_quote = $1;
4169 36         410 my $delimiter = $2;
4170              
4171             # get here document
4172 36 50       82 if ($here_script eq '') {
4173 36         207 $here_script = CORE::substr $_, pos $_;
4174 36         176 $here_script =~ s/.*?\n//oxm;
4175             }
4176 36 50       651 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4177 36         77 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4178 36         109 push @heredoc_delimiter, $delimiter;
4179             }
4180             else {
4181 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4182             }
4183 36         132 return $here_quote;
4184             }
4185              
4186             # <
4187             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4188 42         65 $slash = 'm//';
4189 42         74 my $here_quote = $1;
4190 42         60 my $delimiter = $2;
4191              
4192             # get here document
4193 42 50       94 if ($here_script eq '') {
4194 42         283 $here_script = CORE::substr $_, pos $_;
4195 42         291 $here_script =~ s/.*?\n//oxm;
4196             }
4197 42 50       563 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4198 42         107 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4199 42         70 push @heredoc_delimiter, $delimiter;
4200             }
4201             else {
4202 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4203             }
4204 42         159 return $here_quote;
4205             }
4206              
4207             # <<`HEREDOC`
4208             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4209 0         0 $slash = 'm//';
4210 0         0 my $here_quote = $1;
4211 0         0 my $delimiter = $2;
4212              
4213             # get here document
4214 0 0       0 if ($here_script eq '') {
4215 0         0 $here_script = CORE::substr $_, pos $_;
4216 0         0 $here_script =~ s/.*?\n//oxm;
4217             }
4218 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4219 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4220 0         0 push @heredoc_delimiter, $delimiter;
4221             }
4222             else {
4223 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4224             }
4225 0         0 return $here_quote;
4226             }
4227              
4228             # <<= <=> <= < operator
4229             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4230 11         76 return $1;
4231             }
4232              
4233             #
4234             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4235 0         0 return $1;
4236             }
4237              
4238             # --- glob
4239              
4240             # avoid "Error: Runtime exception" of perl version 5.005_03
4241              
4242             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4243 0         0 return 'Elatin7::glob("' . $1 . '")';
4244             }
4245              
4246             # __DATA__
4247 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4248              
4249             # __END__
4250 200         1134 elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4251              
4252             # \cD Control-D
4253              
4254             # P.68 2.6.8. Other Literal Tokens
4255             # in Chapter 2: Bits and Pieces
4256             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4257              
4258             # P.76 Other Literal Tokens
4259             # in Chapter 2: Bits and Pieces
4260             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4261              
4262 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4263              
4264             # \cZ Control-Z
4265 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4266              
4267             # any operator before div
4268             elsif (/\G (
4269             -- | \+\+ |
4270             [\)\}\]]
4271              
4272 4824         4973 ) /oxgc) { $slash = 'div'; return $1; }
  4824         16394  
4273              
4274             # yada-yada or triple-dot operator
4275             elsif (/\G (
4276             \.\.\.
4277              
4278 7         8 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         19  
4279              
4280             # any operator before m//
4281              
4282             # //, //= (defined-or)
4283              
4284             # P.164 Logical Operators
4285             # in Chapter 10: More Control Structures
4286             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4287              
4288             # P.119 C-Style Logical (Short-Circuit) Operators
4289             # in Chapter 3: Unary and Binary Operators
4290             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4291              
4292             # (and so on)
4293              
4294             # ~~
4295              
4296             # P.221 The Smart Match Operator
4297             # in Chapter 15: Smart Matching and given-when
4298             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4299              
4300             # P.112 Smartmatch Operator
4301             # in Chapter 3: Unary and Binary Operators
4302             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4303              
4304             # (and so on)
4305              
4306             elsif (/\G ((?>
4307              
4308             !~~ | !~ | != | ! |
4309             %= | % |
4310             &&= | && | &= | &\.= | &\. | & |
4311             -= | -> | - |
4312             :(?>\s*)= |
4313             : |
4314             <<>> |
4315             <<= | <=> | <= | < |
4316             == | => | =~ | = |
4317             >>= | >> | >= | > |
4318             \*\*= | \*\* | \*= | \* |
4319             \+= | \+ |
4320             \.\. | \.= | \. |
4321             \/\/= | \/\/ |
4322             \/= | \/ |
4323             \? |
4324             \\ |
4325             \^= | \^\.= | \^\. | \^ |
4326             \b x= |
4327             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4328             ~~ | ~\. | ~ |
4329             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4330             \b(?: print )\b |
4331              
4332             [,;\(\{\[]
4333              
4334 8482         8453 )) /oxgc) { $slash = 'm//'; return $1; }
  8482         27843  
4335              
4336             # other any character
4337 14740         13984 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14740         49971  
4338              
4339             # system error
4340             else {
4341 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4342             }
4343             }
4344              
4345             # escape Latin-7 string
4346             sub e_string {
4347 1718     1718 0 2595 my($string) = @_;
4348 1718         1526 my $e_string = '';
4349              
4350 1718         1687 local $slash = 'm//';
4351              
4352             # P.1024 Appendix W.10 Multibyte Processing
4353             # of ISBN 1-56592-224-7 CJKV Information Processing
4354             # (and so on)
4355              
4356 1718         12491 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4357              
4358             # without { ... }
4359 1718 100 66     6268 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4360 1701 50       2864 if ($string !~ /<
4361 1701         3225 return $string;
4362             }
4363             }
4364              
4365             E_STRING_LOOP:
4366 17         45 while ($string !~ /\G \z/oxgc) {
4367 190 50       11459 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4368             }
4369              
4370             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin7::PREMATCH()]}
4371 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4372 0         0 $e_string .= q{Elatin7::PREMATCH()};
4373 0         0 $slash = 'div';
4374             }
4375              
4376             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin7::MATCH()]}
4377             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4378 0         0 $e_string .= q{Elatin7::MATCH()};
4379 0         0 $slash = 'div';
4380             }
4381              
4382             # $', ${'} --> $', ${'}
4383             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4384 0         0 $e_string .= $1;
4385 0         0 $slash = 'div';
4386             }
4387              
4388             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin7::POSTMATCH()]}
4389             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4390 0         0 $e_string .= q{Elatin7::POSTMATCH()};
4391 0         0 $slash = 'div';
4392             }
4393              
4394             # bareword
4395             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4396 0         0 $e_string .= $1;
4397 0         0 $slash = 'div';
4398             }
4399              
4400             # $0 --> $0
4401             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4402 0         0 $e_string .= $1;
4403 0         0 $slash = 'div';
4404             }
4405             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4406 0         0 $e_string .= $1;
4407 0         0 $slash = 'div';
4408             }
4409              
4410             # $$ --> $$
4411             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4412 0         0 $e_string .= $1;
4413 0         0 $slash = 'div';
4414             }
4415              
4416             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4417             # $1, $2, $3 --> $1, $2, $3 otherwise
4418             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4419 0         0 $e_string .= e_capture($1);
4420 0         0 $slash = 'div';
4421             }
4422             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4423 0         0 $e_string .= e_capture($1);
4424 0         0 $slash = 'div';
4425             }
4426              
4427             # $$foo[ ... ] --> $ $foo->[ ... ]
4428             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4429 0         0 $e_string .= e_capture($1.'->'.$2);
4430 0         0 $slash = 'div';
4431             }
4432              
4433             # $$foo{ ... } --> $ $foo->{ ... }
4434             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4435 0         0 $e_string .= e_capture($1.'->'.$2);
4436 0         0 $slash = 'div';
4437             }
4438              
4439             # $$foo
4440             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4441 0         0 $e_string .= e_capture($1);
4442 0         0 $slash = 'div';
4443             }
4444              
4445             # ${ foo }
4446             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4447 0         0 $e_string .= '${' . $1 . '}';
4448 0         0 $slash = 'div';
4449             }
4450              
4451             # ${ ... }
4452             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4453 3         7 $e_string .= e_capture($1);
4454 3         13 $slash = 'div';
4455             }
4456              
4457             # variable or function
4458             # $ @ % & * $ #
4459             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) {
4460 7         11 $e_string .= $1;
4461 7         19 $slash = 'div';
4462             }
4463             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4464             # $ @ # \ ' " / ? ( ) [ ] < >
4465             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4466 0         0 $e_string .= $1;
4467 0         0 $slash = 'div';
4468             }
4469              
4470             # subroutines of package Elatin7
4471 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4472 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4473 0         0 elsif ($string =~ /\G \b Latin7::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4474 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4475 0         0 elsif ($string =~ /\G \b Latin7::eval \b /oxgc) { $e_string .= 'eval Latin7::escape'; $slash = 'm//'; }
  0         0  
4476 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4477 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin7::chop'; $slash = 'm//'; }
  0         0  
4478 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4479 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4480 0         0 elsif ($string =~ /\G \b Latin7::index \b /oxgc) { $e_string .= 'Latin7::index'; $slash = 'm//'; }
  0         0  
4481 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin7::index'; $slash = 'm//'; }
  0         0  
4482 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4483 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4484 0         0 elsif ($string =~ /\G \b Latin7::rindex \b /oxgc) { $e_string .= 'Latin7::rindex'; $slash = 'm//'; }
  0         0  
4485 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin7::rindex'; $slash = 'm//'; }
  0         0  
4486 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::lc'; $slash = 'm//'; }
  0         0  
4487 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::lcfirst'; $slash = 'm//'; }
  0         0  
4488 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::uc'; $slash = 'm//'; }
  0         0  
4489 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::ucfirst'; $slash = 'm//'; }
  0         0  
4490 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::fc'; $slash = 'm//'; }
  0         0  
4491              
4492             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4493 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4494 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4495 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4496 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4497 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4498 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4499 0         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         0  
4500              
4501 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4502 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4503 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4504 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4505 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4506 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4507 0         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         0  
4508              
4509             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4510 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4511 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4512 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4513 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4514              
4515 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4516 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4517 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::chr'; $slash = 'm//'; }
  0         0  
4518 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4519 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4520 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::glob'; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin7::lc_'; $slash = 'm//'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin7::lcfirst_'; $slash = 'm//'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin7::uc_'; $slash = 'm//'; }
  0         0  
4524 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin7::ucfirst_'; $slash = 'm//'; }
  0         0  
4525 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin7::fc_'; $slash = 'm//'; }
  0         0  
4526 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4527              
4528 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4529 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4530 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin7::chr_'; $slash = 'm//'; }
  0         0  
4531 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4532 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4533 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin7::glob_'; $slash = 'm//'; }
  0         0  
4534 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4535 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4536             # split
4537             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4538 0         0 $slash = 'm//';
4539              
4540 0         0 my $e = '';
4541 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4542 0         0 $e .= $1;
4543             }
4544              
4545             # end of split
4546 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return '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          
    0          
4547              
4548             # split scalar value
4549 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin7::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4550              
4551             # split literal space
4552 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4553 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4554 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4555 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4556 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4557 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4558 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4559 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4560 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4561 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4562 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4563 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4564 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4565 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4566              
4567             # split qq//
4568             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4569 0 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  
  0         0  
4570             else {
4571 0         0 while ($string !~ /\G \z/oxgc) {
4572 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4573 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4574 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4575 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4576 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4577 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4578 0         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         0  
4579             }
4580 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4581             }
4582             }
4583              
4584             # split qr//
4585             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4586 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0         0  
  0         0  
4587             else {
4588 0         0 while ($string !~ /\G \z/oxgc) {
4589 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4590 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4591 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4592 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4593 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4594 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4595 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0         0  
4596 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0         0  
4597             }
4598 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4599             }
4600             }
4601              
4602             # split q//
4603             elsif ($string =~ /\G \b (q) \b /oxgc) {
4604 0 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  
  0         0  
4605             else {
4606 0         0 while ($string !~ /\G \z/oxgc) {
4607 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4608 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4609 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4610 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4611 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4612 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0         0  
4613 0         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         0  
4614             }
4615 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4616             }
4617             }
4618              
4619             # split m//
4620             elsif ($string =~ /\G \b (m) \b /oxgc) {
4621 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0         0  
  0         0  
4622             else {
4623 0         0 while ($string !~ /\G \z/oxgc) {
4624 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4625 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4626 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4627 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4628 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4629 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4630 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0         0  
4631 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0         0  
4632             }
4633 0         0 die __FILE__, ": Search pattern not terminated\n";
4634             }
4635             }
4636              
4637             # split ''
4638             elsif ($string =~ /\G (\') /oxgc) {
4639 0         0 my $q_string = '';
4640 0         0 while ($string !~ /\G \z/oxgc) {
4641 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4642 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4643 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4644 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4645             }
4646 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4647             }
4648              
4649             # split ""
4650             elsif ($string =~ /\G (\") /oxgc) {
4651 0         0 my $qq_string = '';
4652 0         0 while ($string !~ /\G \z/oxgc) {
4653 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4654 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4655 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4656 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4657             }
4658 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4659             }
4660              
4661             # split //
4662             elsif ($string =~ /\G (\/) /oxgc) {
4663 0         0 my $regexp = '';
4664 0         0 while ($string !~ /\G \z/oxgc) {
4665 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4666 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4667 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4668 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4669             }
4670 0         0 die __FILE__, ": Search pattern not terminated\n";
4671             }
4672             }
4673              
4674             # qq//
4675             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4676 0         0 my $ope = $1;
4677 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4678 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4679             }
4680             else {
4681 0         0 my $e = '';
4682 0         0 while ($string !~ /\G \z/oxgc) {
4683 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4684 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4685 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4686 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4687 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4688 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0         0  
4689             }
4690 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4691             }
4692             }
4693              
4694             # qx//
4695             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4696 0         0 my $ope = $1;
4697 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4698 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4699             }
4700             else {
4701 0         0 my $e = '';
4702 0         0 while ($string !~ /\G \z/oxgc) {
4703 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4704 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4705 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4706 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4707 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4708 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4709 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0         0  
4710             }
4711 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4712             }
4713             }
4714              
4715             # q//
4716             elsif ($string =~ /\G \b (q) \b /oxgc) {
4717 0         0 my $ope = $1;
4718 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4719 0         0 $e_string .= e_q($ope,$1,$3,$2);
4720             }
4721             else {
4722 0         0 my $e = '';
4723 0         0 while ($string !~ /\G \z/oxgc) {
4724 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4725 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4726 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4727 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4728 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4729 0         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         0  
4730             }
4731 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4732             }
4733             }
4734              
4735             # ''
4736 0         0 elsif ($string =~ /\G (?
4737              
4738             # ""
4739 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4740              
4741             # ``
4742 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4743              
4744             # <<>> (a safer ARGV)
4745 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4746              
4747             # <<= <=> <= < operator
4748 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4749              
4750             #
4751 0         0 elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4752              
4753             # --- glob
4754             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4755 0         0 $e_string .= 'Elatin7::glob("' . $1 . '")';
4756             }
4757              
4758             # << (bit shift) --- not here document
4759 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4760              
4761             # <<'HEREDOC'
4762             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4763 0         0 $slash = 'm//';
4764 0         0 my $here_quote = $1;
4765 0         0 my $delimiter = $2;
4766              
4767             # get here document
4768 0 0       0 if ($here_script eq '') {
4769 0         0 $here_script = CORE::substr $_, pos $_;
4770 0         0 $here_script =~ s/.*?\n//oxm;
4771             }
4772 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4773 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4774 0         0 push @heredoc_delimiter, $delimiter;
4775             }
4776             else {
4777 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4778             }
4779 0         0 $e_string .= $here_quote;
4780             }
4781              
4782             # <<\HEREDOC
4783             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4784 0         0 $slash = 'm//';
4785 0         0 my $here_quote = $1;
4786 0         0 my $delimiter = $2;
4787              
4788             # get here document
4789 0 0       0 if ($here_script eq '') {
4790 0         0 $here_script = CORE::substr $_, pos $_;
4791 0         0 $here_script =~ s/.*?\n//oxm;
4792             }
4793 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4794 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4795 0         0 push @heredoc_delimiter, $delimiter;
4796             }
4797             else {
4798 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4799             }
4800 0         0 $e_string .= $here_quote;
4801             }
4802              
4803             # <<"HEREDOC"
4804             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4805 0         0 $slash = 'm//';
4806 0         0 my $here_quote = $1;
4807 0         0 my $delimiter = $2;
4808              
4809             # get here document
4810 0 0       0 if ($here_script eq '') {
4811 0         0 $here_script = CORE::substr $_, pos $_;
4812 0         0 $here_script =~ s/.*?\n//oxm;
4813             }
4814 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4815 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4816 0         0 push @heredoc_delimiter, $delimiter;
4817             }
4818             else {
4819 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4820             }
4821 0         0 $e_string .= $here_quote;
4822             }
4823              
4824             # <
4825             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4826 0         0 $slash = 'm//';
4827 0         0 my $here_quote = $1;
4828 0         0 my $delimiter = $2;
4829              
4830             # get here document
4831 0 0       0 if ($here_script eq '') {
4832 0         0 $here_script = CORE::substr $_, pos $_;
4833 0         0 $here_script =~ s/.*?\n//oxm;
4834             }
4835 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4836 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4837 0         0 push @heredoc_delimiter, $delimiter;
4838             }
4839             else {
4840 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4841             }
4842 0         0 $e_string .= $here_quote;
4843             }
4844              
4845             # <<`HEREDOC`
4846             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4847 0         0 $slash = 'm//';
4848 0         0 my $here_quote = $1;
4849 0         0 my $delimiter = $2;
4850              
4851             # get here document
4852 0 0       0 if ($here_script eq '') {
4853 0         0 $here_script = CORE::substr $_, pos $_;
4854 0         0 $here_script =~ s/.*?\n//oxm;
4855             }
4856 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4857 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4858 0         0 push @heredoc_delimiter, $delimiter;
4859             }
4860             else {
4861 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4862             }
4863 0         0 $e_string .= $here_quote;
4864             }
4865              
4866             # any operator before div
4867             elsif ($string =~ /\G (
4868             -- | \+\+ |
4869             [\)\}\]]
4870              
4871 18         22 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         50  
4872              
4873             # yada-yada or triple-dot operator
4874             elsif ($string =~ /\G (
4875             \.\.\.
4876              
4877 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         0  
4878              
4879             # any operator before m//
4880             elsif ($string =~ /\G ((?>
4881              
4882             !~~ | !~ | != | ! |
4883             %= | % |
4884             &&= | && | &= | &\.= | &\. | & |
4885             -= | -> | - |
4886             :(?>\s*)= |
4887             : |
4888             <<>> |
4889             <<= | <=> | <= | < |
4890             == | => | =~ | = |
4891             >>= | >> | >= | > |
4892             \*\*= | \*\* | \*= | \* |
4893             \+= | \+ |
4894             \.\. | \.= | \. |
4895             \/\/= | \/\/ |
4896             \/= | \/ |
4897             \? |
4898             \\ |
4899             \^= | \^\.= | \^\. | \^ |
4900             \b x= |
4901             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4902             ~~ | ~\. | ~ |
4903             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4904             \b(?: print )\b |
4905              
4906             [,;\(\{\[]
4907              
4908 31         34 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         100  
4909              
4910             # other any character
4911 131         288 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4912              
4913             # system error
4914             else {
4915 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4916             }
4917             }
4918              
4919 17         63 return $e_string;
4920             }
4921              
4922             #
4923             # character class
4924             #
4925             sub character_class {
4926 1914     1914 0 1967 my($char,$modifier) = @_;
4927              
4928 1914 100       2203 if ($char eq '.') {
4929 52 100       85 if ($modifier =~ /s/) {
4930 17         30 return '${Elatin7::dot_s}';
4931             }
4932             else {
4933 35         57 return '${Elatin7::dot}';
4934             }
4935             }
4936             else {
4937 1862         2326 return Elatin7::classic_character_class($char);
4938             }
4939             }
4940              
4941             #
4942             # escape capture ($1, $2, $3, ...)
4943             #
4944             sub e_capture {
4945              
4946 212     212 0 704 return join '', '${', $_[0], '}';
4947             }
4948              
4949             #
4950             # escape transliteration (tr/// or y///)
4951             #
4952             sub e_tr {
4953 3     3 0 4 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4954 3         4 my $e_tr = '';
4955 3   50     4 $modifier ||= '';
4956              
4957 3         4 $slash = 'div';
4958              
4959             # quote character class 1
4960 3         4 $charclass = q_tr($charclass);
4961              
4962             # quote character class 2
4963 3         4 $charclass2 = q_tr($charclass2);
4964              
4965             # /b /B modifier
4966 3 50       7 if ($modifier =~ tr/bB//d) {
4967 0 0       0 if ($variable eq '') {
4968 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4969             }
4970             else {
4971 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4972             }
4973             }
4974             else {
4975 3 100       4 if ($variable eq '') {
4976 2         20 $e_tr = qq{Elatin7::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4977             }
4978             else {
4979 1         4 $e_tr = qq{Elatin7::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4980             }
4981             }
4982              
4983             # clear tr/// variable
4984 3         4 $tr_variable = '';
4985 3         3 $bind_operator = '';
4986              
4987 3         14 return $e_tr;
4988             }
4989              
4990             #
4991             # quote for escape transliteration (tr/// or y///)
4992             #
4993             sub q_tr {
4994 6     6 0 6 my($charclass) = @_;
4995              
4996             # quote character class
4997 6 50       8 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4998 6         7 return e_q('', "'", "'", $charclass); # --> q' '
4999             }
5000             elsif ($charclass !~ /\//oxms) {
5001 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
5002             }
5003             elsif ($charclass !~ /\#/oxms) {
5004 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
5005             }
5006             elsif ($charclass !~ /[\<\>]/oxms) {
5007 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
5008             }
5009             elsif ($charclass !~ /[\(\)]/oxms) {
5010 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
5011             }
5012             elsif ($charclass !~ /[\{\}]/oxms) {
5013 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5014             }
5015             else {
5016 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5017 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5018 0         0 return e_q('q', $char, $char, $charclass);
5019             }
5020             }
5021             }
5022              
5023 0         0 return e_q('q', '{', '}', $charclass);
5024             }
5025              
5026             #
5027             # escape q string (q//, '')
5028             #
5029             sub e_q {
5030 1092     1092 0 1631 my($ope,$delimiter,$end_delimiter,$string) = @_;
5031              
5032 1092         1011 $slash = 'div';
5033              
5034 1092         4552 return join '', $ope, $delimiter, $string, $end_delimiter;
5035             }
5036              
5037             #
5038             # escape qq string (qq//, "", qx//, ``)
5039             #
5040             sub e_qq {
5041 3953     3953 0 5525 my($ope,$delimiter,$end_delimiter,$string) = @_;
5042              
5043 3953         3445 $slash = 'div';
5044              
5045 3953         3059 my $left_e = 0;
5046 3953         2581 my $right_e = 0;
5047              
5048             # split regexp
5049 3953         116149 my @char = $string =~ /\G((?>
5050             [^\\\$] |
5051             \\x\{ (?>[0-9A-Fa-f]+) \} |
5052             \\o\{ (?>[0-7]+) \} |
5053             \\N\{ (?>[^0-9\}][^\}]*) \} |
5054             \\ $q_char |
5055             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5056             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5057             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5058             \$ (?>\s* [0-9]+) |
5059             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5060             \$ \$ (?![\w\{]) |
5061             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5062             $q_char
5063             ))/oxmsg;
5064              
5065 3953         11895 for (my $i=0; $i <= $#char; $i++) {
5066              
5067             # "\L\u" --> "\u\L"
5068 111834 50 33     392700 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5069 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5070             }
5071              
5072             # "\U\l" --> "\l\U"
5073             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5074 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5075             }
5076              
5077             # octal escape sequence
5078             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5079 1         3 $char[$i] = Elatin7::octchr($1);
5080             }
5081              
5082             # hexadecimal escape sequence
5083             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5084 1         3 $char[$i] = Elatin7::hexchr($1);
5085             }
5086              
5087             # \N{CHARNAME} --> N{CHARNAME}
5088             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5089 0         0 $char[$i] = $1;
5090             }
5091              
5092 111834 100       1050694 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5093             }
5094              
5095             # \F
5096             #
5097             # P.69 Table 2-6. Translation escapes
5098             # in Chapter 2: Bits and Pieces
5099             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5100             # (and so on)
5101              
5102             # \u \l \U \L \F \Q \E
5103 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5104 484 50       1025 if ($right_e < $left_e) {
5105 0         0 $char[$i] = '\\' . $char[$i];
5106             }
5107             }
5108             elsif ($char[$i] eq '\u') {
5109              
5110             # "STRING @{[ LIST EXPR ]} MORE STRING"
5111              
5112             # P.257 Other Tricks You Can Do with Hard References
5113             # in Chapter 8: References
5114             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5115              
5116             # P.353 Other Tricks You Can Do with Hard References
5117             # in Chapter 8: References
5118             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5119              
5120             # (and so on)
5121              
5122 0         0 $char[$i] = '@{[Elatin7::ucfirst qq<';
5123 0         0 $left_e++;
5124             }
5125             elsif ($char[$i] eq '\l') {
5126 0         0 $char[$i] = '@{[Elatin7::lcfirst qq<';
5127 0         0 $left_e++;
5128             }
5129             elsif ($char[$i] eq '\U') {
5130 0         0 $char[$i] = '@{[Elatin7::uc qq<';
5131 0         0 $left_e++;
5132             }
5133             elsif ($char[$i] eq '\L') {
5134 0         0 $char[$i] = '@{[Elatin7::lc qq<';
5135 0         0 $left_e++;
5136             }
5137             elsif ($char[$i] eq '\F') {
5138 24         24 $char[$i] = '@{[Elatin7::fc qq<';
5139 24         40 $left_e++;
5140             }
5141             elsif ($char[$i] eq '\Q') {
5142 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5143 0         0 $left_e++;
5144             }
5145             elsif ($char[$i] eq '\E') {
5146 24 50       28 if ($right_e < $left_e) {
5147 24         23 $char[$i] = '>]}';
5148 24         42 $right_e++;
5149             }
5150             else {
5151 0         0 $char[$i] = '';
5152             }
5153             }
5154             elsif ($char[$i] eq '\Q') {
5155 0         0 while (1) {
5156 0 0       0 if (++$i > $#char) {
5157 0         0 last;
5158             }
5159 0 0       0 if ($char[$i] eq '\E') {
5160 0         0 last;
5161             }
5162             }
5163             }
5164             elsif ($char[$i] eq '\E') {
5165             }
5166              
5167             # $0 --> $0
5168             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5169             }
5170             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5171             }
5172              
5173             # $$ --> $$
5174             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5175             }
5176              
5177             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5178             # $1, $2, $3 --> $1, $2, $3 otherwise
5179             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5180 205         310 $char[$i] = e_capture($1);
5181             }
5182             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5183 0         0 $char[$i] = e_capture($1);
5184             }
5185              
5186             # $$foo[ ... ] --> $ $foo->[ ... ]
5187             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5188 0         0 $char[$i] = e_capture($1.'->'.$2);
5189             }
5190              
5191             # $$foo{ ... } --> $ $foo->{ ... }
5192             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5193 0         0 $char[$i] = e_capture($1.'->'.$2);
5194             }
5195              
5196             # $$foo
5197             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5198 0         0 $char[$i] = e_capture($1);
5199             }
5200              
5201             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
5202             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5203 44         100 $char[$i] = '@{[Elatin7::PREMATCH()]}';
5204             }
5205              
5206             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5207             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5208 45         98 $char[$i] = '@{[Elatin7::MATCH()]}';
5209             }
5210              
5211             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5212             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5213 33         83 $char[$i] = '@{[Elatin7::POSTMATCH()]}';
5214             }
5215              
5216             # ${ foo } --> ${ foo }
5217             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5218             }
5219              
5220             # ${ ... }
5221             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5222 0         0 $char[$i] = e_capture($1);
5223             }
5224             }
5225              
5226             # return string
5227 3953 50       5960 if ($left_e > $right_e) {
5228 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5229             }
5230 3953         28323 return join '', $ope, $delimiter, @char, $end_delimiter;
5231             }
5232              
5233             #
5234             # escape qw string (qw//)
5235             #
5236             sub e_qw {
5237 16     16 0 72 my($ope,$delimiter,$end_delimiter,$string) = @_;
5238              
5239 16         19 $slash = 'div';
5240              
5241             # choice again delimiter
5242 16         185 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         523  
5243 16 50       92 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5244 16         119 return join '', $ope, $delimiter, $string, $end_delimiter;
5245             }
5246             elsif (not $octet{')'}) {
5247 0         0 return join '', $ope, '(', $string, ')';
5248             }
5249             elsif (not $octet{'}'}) {
5250 0         0 return join '', $ope, '{', $string, '}';
5251             }
5252             elsif (not $octet{']'}) {
5253 0         0 return join '', $ope, '[', $string, ']';
5254             }
5255             elsif (not $octet{'>'}) {
5256 0         0 return join '', $ope, '<', $string, '>';
5257             }
5258             else {
5259 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5260 0 0       0 if (not $octet{$char}) {
5261 0         0 return join '', $ope, $char, $string, $char;
5262             }
5263             }
5264             }
5265              
5266             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5267 0         0 my @string = CORE::split(/\s+/, $string);
5268 0         0 for my $string (@string) {
5269 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5270 0         0 for my $octet (@octet) {
5271 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5272 0         0 $octet = '\\' . $1;
5273             }
5274             }
5275 0         0 $string = join '', @octet;
5276             }
5277 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5278             }
5279              
5280             #
5281             # escape here document (<<"HEREDOC", <
5282             #
5283             sub e_heredoc {
5284 78     78 0 151 my($string) = @_;
5285              
5286 78         78 $slash = 'm//';
5287              
5288 78         220 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5289              
5290 78         375 my $left_e = 0;
5291 78         69 my $right_e = 0;
5292              
5293             # split regexp
5294 78         6334 my @char = $string =~ /\G((?>
5295             [^\\\$] |
5296             \\x\{ (?>[0-9A-Fa-f]+) \} |
5297             \\o\{ (?>[0-7]+) \} |
5298             \\N\{ (?>[^0-9\}][^\}]*) \} |
5299             \\ $q_char |
5300             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5301             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5302             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5303             \$ (?>\s* [0-9]+) |
5304             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5305             \$ \$ (?![\w\{]) |
5306             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5307             $q_char
5308             ))/oxmsg;
5309              
5310 78         373 for (my $i=0; $i <= $#char; $i++) {
5311              
5312             # "\L\u" --> "\u\L"
5313 2882 50 33     10418 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5314 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5315             }
5316              
5317             # "\U\l" --> "\l\U"
5318             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5319 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5320             }
5321              
5322             # octal escape sequence
5323             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5324 1         3 $char[$i] = Elatin7::octchr($1);
5325             }
5326              
5327             # hexadecimal escape sequence
5328             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5329 1         2 $char[$i] = Elatin7::hexchr($1);
5330             }
5331              
5332             # \N{CHARNAME} --> N{CHARNAME}
5333             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5334 0         0 $char[$i] = $1;
5335             }
5336              
5337 2882 50       28406 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5338             }
5339              
5340             # \u \l \U \L \F \Q \E
5341 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5342 0 0       0 if ($right_e < $left_e) {
5343 0         0 $char[$i] = '\\' . $char[$i];
5344             }
5345             }
5346             elsif ($char[$i] eq '\u') {
5347 0         0 $char[$i] = '@{[Elatin7::ucfirst qq<';
5348 0         0 $left_e++;
5349             }
5350             elsif ($char[$i] eq '\l') {
5351 0         0 $char[$i] = '@{[Elatin7::lcfirst qq<';
5352 0         0 $left_e++;
5353             }
5354             elsif ($char[$i] eq '\U') {
5355 0         0 $char[$i] = '@{[Elatin7::uc qq<';
5356 0         0 $left_e++;
5357             }
5358             elsif ($char[$i] eq '\L') {
5359 0         0 $char[$i] = '@{[Elatin7::lc qq<';
5360 0         0 $left_e++;
5361             }
5362             elsif ($char[$i] eq '\F') {
5363 0         0 $char[$i] = '@{[Elatin7::fc qq<';
5364 0         0 $left_e++;
5365             }
5366             elsif ($char[$i] eq '\Q') {
5367 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5368 0         0 $left_e++;
5369             }
5370             elsif ($char[$i] eq '\E') {
5371 0 0       0 if ($right_e < $left_e) {
5372 0         0 $char[$i] = '>]}';
5373 0         0 $right_e++;
5374             }
5375             else {
5376 0         0 $char[$i] = '';
5377             }
5378             }
5379             elsif ($char[$i] eq '\Q') {
5380 0         0 while (1) {
5381 0 0       0 if (++$i > $#char) {
5382 0         0 last;
5383             }
5384 0 0       0 if ($char[$i] eq '\E') {
5385 0         0 last;
5386             }
5387             }
5388             }
5389             elsif ($char[$i] eq '\E') {
5390             }
5391              
5392             # $0 --> $0
5393             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5394             }
5395             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5396             }
5397              
5398             # $$ --> $$
5399             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5400             }
5401              
5402             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5403             # $1, $2, $3 --> $1, $2, $3 otherwise
5404             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5405 0         0 $char[$i] = e_capture($1);
5406             }
5407             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5408 0         0 $char[$i] = e_capture($1);
5409             }
5410              
5411             # $$foo[ ... ] --> $ $foo->[ ... ]
5412             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5413 0         0 $char[$i] = e_capture($1.'->'.$2);
5414             }
5415              
5416             # $$foo{ ... } --> $ $foo->{ ... }
5417             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5418 0         0 $char[$i] = e_capture($1.'->'.$2);
5419             }
5420              
5421             # $$foo
5422             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5423 0         0 $char[$i] = e_capture($1);
5424             }
5425              
5426             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
5427             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5428 8         33 $char[$i] = '@{[Elatin7::PREMATCH()]}';
5429             }
5430              
5431             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5432             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5433 8         33 $char[$i] = '@{[Elatin7::MATCH()]}';
5434             }
5435              
5436             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5437             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5438 6         28 $char[$i] = '@{[Elatin7::POSTMATCH()]}';
5439             }
5440              
5441             # ${ foo } --> ${ foo }
5442             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5443             }
5444              
5445             # ${ ... }
5446             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5447 0         0 $char[$i] = e_capture($1);
5448             }
5449             }
5450              
5451             # return string
5452 78 50       141 if ($left_e > $right_e) {
5453 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5454             }
5455 78         574 return join '', @char;
5456             }
5457              
5458             #
5459             # escape regexp (m//, qr//)
5460             #
5461             sub e_qr {
5462 651     651 0 1389 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5463 651   100     1783 $modifier ||= '';
5464              
5465 651         790 $modifier =~ tr/p//d;
5466 651 50       1241 if ($modifier =~ /([adlu])/oxms) {
5467 0         0 my $line = 0;
5468 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5469 0 0       0 if ($filename ne __FILE__) {
5470 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5471 0         0 last;
5472             }
5473             }
5474 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5475             }
5476              
5477 651         652 $slash = 'div';
5478              
5479             # literal null string pattern
5480 651 100       1956 if ($string eq '') {
    100          
5481 8         9 $modifier =~ tr/bB//d;
5482 8         6 $modifier =~ tr/i//d;
5483 8         32 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5484             }
5485              
5486             # /b /B modifier
5487             elsif ($modifier =~ tr/bB//d) {
5488              
5489             # choice again delimiter
5490 2 50       12 if ($delimiter =~ / [\@:] /oxms) {
5491 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5492 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5493 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5494 0         0 $delimiter = '(';
5495 0         0 $end_delimiter = ')';
5496             }
5497             elsif (not $octet{'}'}) {
5498 0         0 $delimiter = '{';
5499 0         0 $end_delimiter = '}';
5500             }
5501             elsif (not $octet{']'}) {
5502 0         0 $delimiter = '[';
5503 0         0 $end_delimiter = ']';
5504             }
5505             elsif (not $octet{'>'}) {
5506 0         0 $delimiter = '<';
5507 0         0 $end_delimiter = '>';
5508             }
5509             else {
5510 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5511 0 0       0 if (not $octet{$char}) {
5512 0         0 $delimiter = $char;
5513 0         0 $end_delimiter = $char;
5514 0         0 last;
5515             }
5516             }
5517             }
5518             }
5519              
5520 2 50 33     12 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5521 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5522             }
5523             else {
5524 2         9 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5525             }
5526             }
5527              
5528 641 100       1123 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5529 641         1825 my $metachar = qr/[\@\\|[\]{^]/oxms;
5530              
5531             # split regexp
5532 641         53300 my @char = $string =~ /\G((?>
5533             [^\\\$\@\[\(] |
5534             \\x (?>[0-9A-Fa-f]{1,2}) |
5535             \\ (?>[0-7]{2,3}) |
5536             \\c [\x40-\x5F] |
5537             \\x\{ (?>[0-9A-Fa-f]+) \} |
5538             \\o\{ (?>[0-7]+) \} |
5539             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5540             \\ $q_char |
5541             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5542             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5543             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5544             [\$\@] $qq_variable |
5545             \$ (?>\s* [0-9]+) |
5546             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5547             \$ \$ (?![\w\{]) |
5548             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5549             \[\^ |
5550             \[\: (?>[a-z]+) :\] |
5551             \[\:\^ (?>[a-z]+) :\] |
5552             \(\? |
5553             $q_char
5554             ))/oxmsg;
5555              
5556             # choice again delimiter
5557 641 50       2421 if ($delimiter =~ / [\@:] /oxms) {
5558 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5559 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5560 0         0 $delimiter = '(';
5561 0         0 $end_delimiter = ')';
5562             }
5563             elsif (not $octet{'}'}) {
5564 0         0 $delimiter = '{';
5565 0         0 $end_delimiter = '}';
5566             }
5567             elsif (not $octet{']'}) {
5568 0         0 $delimiter = '[';
5569 0         0 $end_delimiter = ']';
5570             }
5571             elsif (not $octet{'>'}) {
5572 0         0 $delimiter = '<';
5573 0         0 $end_delimiter = '>';
5574             }
5575             else {
5576 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5577 0 0       0 if (not $octet{$char}) {
5578 0         0 $delimiter = $char;
5579 0         0 $end_delimiter = $char;
5580 0         0 last;
5581             }
5582             }
5583             }
5584             }
5585              
5586 641         612 my $left_e = 0;
5587 641         526 my $right_e = 0;
5588 641         1326 for (my $i=0; $i <= $#char; $i++) {
5589              
5590             # "\L\u" --> "\u\L"
5591 1867 50 66     9664 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5592 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5593             }
5594              
5595             # "\U\l" --> "\l\U"
5596             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5597 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5598             }
5599              
5600             # octal escape sequence
5601             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5602 1         4 $char[$i] = Elatin7::octchr($1);
5603             }
5604              
5605             # hexadecimal escape sequence
5606             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5607 1         3 $char[$i] = Elatin7::hexchr($1);
5608             }
5609              
5610             # \b{...} --> b\{...}
5611             # \B{...} --> B\{...}
5612             # \N{CHARNAME} --> N\{CHARNAME}
5613             # \p{PROPERTY} --> p\{PROPERTY}
5614             # \P{PROPERTY} --> P\{PROPERTY}
5615             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5616 6         17 $char[$i] = $1 . '\\' . $2;
5617             }
5618              
5619             # \p, \P, \X --> p, P, X
5620             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5621 4         10 $char[$i] = $1;
5622             }
5623              
5624 1867 100 100     4814 if (0) {
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5625             }
5626              
5627             # join separated multiple-octet
5628 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5629 6 50 33     81 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)) {
    50 33        
    50 33        
      33        
      66        
      33        
5630 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
5631             }
5632             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)) {
5633 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
5634             }
5635             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)) {
5636 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
5637             }
5638             }
5639              
5640             # open character class [...]
5641             elsif ($char[$i] eq '[') {
5642 328         340 my $left = $i;
5643              
5644             # [] make die "Unmatched [] in regexp ...\n"
5645             # (and so on)
5646              
5647 328 100       684 if ($char[$i+1] eq ']') {
5648 3         4 $i++;
5649             }
5650              
5651 328         261 while (1) {
5652 1379 50       1607 if (++$i > $#char) {
5653 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5654             }
5655 1379 100       1813 if ($char[$i] eq ']') {
5656 328         249 my $right = $i;
5657              
5658             # [...]
5659 328 100       1448 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5660 30         62 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         103  
5661             }
5662             else {
5663 298         830 splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
5664             }
5665              
5666 328         374 $i = $left;
5667 328         760 last;
5668             }
5669             }
5670             }
5671              
5672             # open character class [^...]
5673             elsif ($char[$i] eq '[^') {
5674 74         68 my $left = $i;
5675              
5676             # [^] make die "Unmatched [] in regexp ...\n"
5677             # (and so on)
5678              
5679 74 100       135 if ($char[$i+1] eq ']') {
5680 4         5 $i++;
5681             }
5682              
5683 74         61 while (1) {
5684 272 50       323 if (++$i > $#char) {
5685 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5686             }
5687 272 100       404 if ($char[$i] eq ']') {
5688 74         62 my $right = $i;
5689              
5690             # [^...]
5691 74 100       315 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5692 30         54 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         116  
5693             }
5694             else {
5695 44         152 splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5696             }
5697              
5698 74         94 $i = $left;
5699 74         172 last;
5700             }
5701             }
5702             }
5703              
5704             # rewrite character class or escape character
5705             elsif (my $char = character_class($char[$i],$modifier)) {
5706 139         477 $char[$i] = $char;
5707             }
5708              
5709             # /i modifier
5710             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
5711 20 50       33 if (CORE::length(Elatin7::fc($char[$i])) == 1) {
5712 20         31 $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
5713             }
5714             else {
5715 0         0 $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
5716             }
5717             }
5718              
5719             # \u \l \U \L \F \Q \E
5720             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5721 1 50       9 if ($right_e < $left_e) {
5722 0         0 $char[$i] = '\\' . $char[$i];
5723             }
5724             }
5725             elsif ($char[$i] eq '\u') {
5726 0         0 $char[$i] = '@{[Elatin7::ucfirst qq<';
5727 0         0 $left_e++;
5728             }
5729             elsif ($char[$i] eq '\l') {
5730 0         0 $char[$i] = '@{[Elatin7::lcfirst qq<';
5731 0         0 $left_e++;
5732             }
5733             elsif ($char[$i] eq '\U') {
5734 1         1 $char[$i] = '@{[Elatin7::uc qq<';
5735 1         5 $left_e++;
5736             }
5737             elsif ($char[$i] eq '\L') {
5738 1         2 $char[$i] = '@{[Elatin7::lc qq<';
5739 1         4 $left_e++;
5740             }
5741             elsif ($char[$i] eq '\F') {
5742 18         19 $char[$i] = '@{[Elatin7::fc qq<';
5743 18         78 $left_e++;
5744             }
5745             elsif ($char[$i] eq '\Q') {
5746 1         2 $char[$i] = '@{[CORE::quotemeta qq<';
5747 1         5 $left_e++;
5748             }
5749             elsif ($char[$i] eq '\E') {
5750 21 50       32 if ($right_e < $left_e) {
5751 21         22 $char[$i] = '>]}';
5752 21         77 $right_e++;
5753             }
5754             else {
5755 0         0 $char[$i] = '';
5756             }
5757             }
5758             elsif ($char[$i] eq '\Q') {
5759 0         0 while (1) {
5760 0 0       0 if (++$i > $#char) {
5761 0         0 last;
5762             }
5763 0 0       0 if ($char[$i] eq '\E') {
5764 0         0 last;
5765             }
5766             }
5767             }
5768             elsif ($char[$i] eq '\E') {
5769             }
5770              
5771             # $0 --> $0
5772             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5773 0 0       0 if ($ignorecase) {
5774 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5775             }
5776             }
5777             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5778 0 0       0 if ($ignorecase) {
5779 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5780             }
5781             }
5782              
5783             # $$ --> $$
5784             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5785             }
5786              
5787             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5788             # $1, $2, $3 --> $1, $2, $3 otherwise
5789             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5790 0         0 $char[$i] = e_capture($1);
5791 0 0       0 if ($ignorecase) {
5792 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5793             }
5794             }
5795             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5796 0         0 $char[$i] = e_capture($1);
5797 0 0       0 if ($ignorecase) {
5798 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5799             }
5800             }
5801              
5802             # $$foo[ ... ] --> $ $foo->[ ... ]
5803             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5804 0         0 $char[$i] = e_capture($1.'->'.$2);
5805 0 0       0 if ($ignorecase) {
5806 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5807             }
5808             }
5809              
5810             # $$foo{ ... } --> $ $foo->{ ... }
5811             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5812 0         0 $char[$i] = e_capture($1.'->'.$2);
5813 0 0       0 if ($ignorecase) {
5814 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5815             }
5816             }
5817              
5818             # $$foo
5819             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5820 0         0 $char[$i] = e_capture($1);
5821 0 0       0 if ($ignorecase) {
5822 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5823             }
5824             }
5825              
5826             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
5827             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5828 8 50       20 if ($ignorecase) {
5829 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
5830             }
5831             else {
5832 8         32 $char[$i] = '@{[Elatin7::PREMATCH()]}';
5833             }
5834             }
5835              
5836             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5837             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5838 8 50       18 if ($ignorecase) {
5839 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
5840             }
5841             else {
5842 8         36 $char[$i] = '@{[Elatin7::MATCH()]}';
5843             }
5844             }
5845              
5846             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5847             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5848 6 50       12 if ($ignorecase) {
5849 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
5850             }
5851             else {
5852 6         26 $char[$i] = '@{[Elatin7::POSTMATCH()]}';
5853             }
5854             }
5855              
5856             # ${ foo }
5857             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5858 0 0       0 if ($ignorecase) {
5859 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5860             }
5861             }
5862              
5863             # ${ ... }
5864             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5865 0         0 $char[$i] = e_capture($1);
5866 0 0       0 if ($ignorecase) {
5867 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5868             }
5869             }
5870              
5871             # $scalar or @array
5872             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5873 21         59 $char[$i] = e_string($char[$i]);
5874 21 100       66 if ($ignorecase) {
5875 11         65 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5876             }
5877             }
5878              
5879             # quote character before ? + * {
5880             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5881 138 100 33     921 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5882             }
5883             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5884 0         0 my $char = $char[$i-1];
5885 0 0       0 if ($char[$i] eq '{') {
5886 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5887             }
5888             else {
5889 0         0 die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5890             }
5891             }
5892             else {
5893 127         666 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5894             }
5895             }
5896             }
5897              
5898             # make regexp string
5899 641         719 $modifier =~ tr/i//d;
5900 641 50       1102 if ($left_e > $right_e) {
5901 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5902 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5903             }
5904             else {
5905 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5906             }
5907             }
5908 641 50 33     3064 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5909 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5910             }
5911             else {
5912 641         4435 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5913             }
5914             }
5915              
5916             #
5917             # double quote stuff
5918             #
5919             sub qq_stuff {
5920 180     180 0 149 my($delimiter,$end_delimiter,$stuff) = @_;
5921              
5922             # scalar variable or array variable
5923 180 100       291 if ($stuff =~ /\A [\$\@] /oxms) {
5924 100         282 return $stuff;
5925             }
5926              
5927             # quote by delimiter
5928 80         126 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         189  
5929 80         160 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5930 80 50       110 next if $char eq $delimiter;
5931 80 50       94 next if $char eq $end_delimiter;
5932 80 50       120 if (not $octet{$char}) {
5933 80         313 return join '', 'qq', $char, $stuff, $char;
5934             }
5935             }
5936 0         0 return join '', 'qq', '<', $stuff, '>';
5937             }
5938              
5939             #
5940             # escape regexp (m'', qr'', and m''b, qr''b)
5941             #
5942             sub e_qr_q {
5943 10     10 0 22 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5944 10   50     33 $modifier ||= '';
5945              
5946 10         11 $modifier =~ tr/p//d;
5947 10 50       14 if ($modifier =~ /([adlu])/oxms) {
5948 0         0 my $line = 0;
5949 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5950 0 0       0 if ($filename ne __FILE__) {
5951 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5952 0         0 last;
5953             }
5954             }
5955 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5956             }
5957              
5958 10         10 $slash = 'div';
5959              
5960             # literal null string pattern
5961 10 100       23 if ($string eq '') {
    50          
5962 8         4 $modifier =~ tr/bB//d;
5963 8         10 $modifier =~ tr/i//d;
5964 8         33 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5965             }
5966              
5967             # with /b /B modifier
5968             elsif ($modifier =~ tr/bB//d) {
5969 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5970             }
5971              
5972             # without /b /B modifier
5973             else {
5974 2         6 return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5975             }
5976             }
5977              
5978             #
5979             # escape regexp (m'', qr'')
5980             #
5981             sub e_qr_qt {
5982 2     2 0 4 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5983              
5984 2 50       5 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5985              
5986             # split regexp
5987 2         66 my @char = $string =~ /\G((?>
5988             [^\\\[\$\@\/] |
5989             [\x00-\xFF] |
5990             \[\^ |
5991             \[\: (?>[a-z]+) \:\] |
5992             \[\:\^ (?>[a-z]+) \:\] |
5993             [\$\@\/] |
5994             \\ (?:$q_char) |
5995             (?:$q_char)
5996             ))/oxmsg;
5997              
5998             # unescape character
5999 2         8 for (my $i=0; $i <= $#char; $i++) {
6000 2 50 33     15 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
6001             }
6002              
6003             # open character class [...]
6004 0         0 elsif ($char[$i] eq '[') {
6005 0         0 my $left = $i;
6006 0 0       0 if ($char[$i+1] eq ']') {
6007 0         0 $i++;
6008             }
6009 0         0 while (1) {
6010 0 0       0 if (++$i > $#char) {
6011 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6012             }
6013 0 0       0 if ($char[$i] eq ']') {
6014 0         0 my $right = $i;
6015              
6016             # [...]
6017 0         0 splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6018              
6019 0         0 $i = $left;
6020 0         0 last;
6021             }
6022             }
6023             }
6024              
6025             # open character class [^...]
6026             elsif ($char[$i] eq '[^') {
6027 0         0 my $left = $i;
6028 0 0       0 if ($char[$i+1] eq ']') {
6029 0         0 $i++;
6030             }
6031 0         0 while (1) {
6032 0 0       0 if (++$i > $#char) {
6033 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6034             }
6035 0 0       0 if ($char[$i] eq ']') {
6036 0         0 my $right = $i;
6037              
6038             # [^...]
6039 0         0 splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6040              
6041 0         0 $i = $left;
6042 0         0 last;
6043             }
6044             }
6045             }
6046              
6047             # escape $ @ / and \
6048             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6049 0         0 $char[$i] = '\\' . $char[$i];
6050             }
6051              
6052             # rewrite character class or escape character
6053             elsif (my $char = character_class($char[$i],$modifier)) {
6054 0         0 $char[$i] = $char;
6055             }
6056              
6057             # /i modifier
6058             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6059 0 0       0 if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6060 0         0 $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6061             }
6062             else {
6063 0         0 $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
6064             }
6065             }
6066              
6067             # quote character before ? + * {
6068             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6069 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6070             }
6071             else {
6072 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6073             }
6074             }
6075             }
6076              
6077 2         3 $delimiter = '/';
6078 2         4 $end_delimiter = '/';
6079              
6080 2         3 $modifier =~ tr/i//d;
6081 2         11 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6082             }
6083              
6084             #
6085             # escape regexp (m''b, qr''b)
6086             #
6087             sub e_qr_qb {
6088 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6089              
6090             # split regexp
6091 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6092              
6093             # unescape character
6094 0         0 for (my $i=0; $i <= $#char; $i++) {
6095 0 0       0 if (0) {
    0          
6096             }
6097              
6098             # remain \\
6099 0         0 elsif ($char[$i] eq '\\\\') {
6100             }
6101              
6102             # escape $ @ / and \
6103             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6104 0         0 $char[$i] = '\\' . $char[$i];
6105             }
6106             }
6107              
6108 0         0 $delimiter = '/';
6109 0         0 $end_delimiter = '/';
6110 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6111             }
6112              
6113             #
6114             # escape regexp (s/here//)
6115             #
6116             sub e_s1 {
6117 76     76 0 128 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6118 76   100     217 $modifier ||= '';
6119              
6120 76         74 $modifier =~ tr/p//d;
6121 76 50       173 if ($modifier =~ /([adlu])/oxms) {
6122 0         0 my $line = 0;
6123 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6124 0 0       0 if ($filename ne __FILE__) {
6125 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6126 0         0 last;
6127             }
6128             }
6129 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6130             }
6131              
6132 76         87 $slash = 'div';
6133              
6134             # literal null string pattern
6135 76 100       204 if ($string eq '') {
    50          
6136 8         6 $modifier =~ tr/bB//d;
6137 8         6 $modifier =~ tr/i//d;
6138 8         42 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6139             }
6140              
6141             # /b /B modifier
6142             elsif ($modifier =~ tr/bB//d) {
6143              
6144             # choice again delimiter
6145 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
6146 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6147 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6148 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6149 0         0 $delimiter = '(';
6150 0         0 $end_delimiter = ')';
6151             }
6152             elsif (not $octet{'}'}) {
6153 0         0 $delimiter = '{';
6154 0         0 $end_delimiter = '}';
6155             }
6156             elsif (not $octet{']'}) {
6157 0         0 $delimiter = '[';
6158 0         0 $end_delimiter = ']';
6159             }
6160             elsif (not $octet{'>'}) {
6161 0         0 $delimiter = '<';
6162 0         0 $end_delimiter = '>';
6163             }
6164             else {
6165 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6166 0 0       0 if (not $octet{$char}) {
6167 0         0 $delimiter = $char;
6168 0         0 $end_delimiter = $char;
6169 0         0 last;
6170             }
6171             }
6172             }
6173             }
6174              
6175 0         0 my $prematch = '';
6176 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6177             }
6178              
6179 68 100       128 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6180 68         202 my $metachar = qr/[\@\\|[\]{^]/oxms;
6181              
6182             # split regexp
6183 68         13915 my @char = $string =~ /\G((?>
6184             [^\\\$\@\[\(] |
6185             \\ (?>[1-9][0-9]*) |
6186             \\g (?>\s*) (?>[1-9][0-9]*) |
6187             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6188             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6189             \\x (?>[0-9A-Fa-f]{1,2}) |
6190             \\ (?>[0-7]{2,3}) |
6191             \\c [\x40-\x5F] |
6192             \\x\{ (?>[0-9A-Fa-f]+) \} |
6193             \\o\{ (?>[0-7]+) \} |
6194             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6195             \\ $q_char |
6196             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6197             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6198             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6199             [\$\@] $qq_variable |
6200             \$ (?>\s* [0-9]+) |
6201             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6202             \$ \$ (?![\w\{]) |
6203             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6204             \[\^ |
6205             \[\: (?>[a-z]+) :\] |
6206             \[\:\^ (?>[a-z]+) :\] |
6207             \(\? |
6208             $q_char
6209             ))/oxmsg;
6210              
6211             # choice again delimiter
6212 68 50       465 if ($delimiter =~ / [\@:] /oxms) {
6213 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6214 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6215 0         0 $delimiter = '(';
6216 0         0 $end_delimiter = ')';
6217             }
6218             elsif (not $octet{'}'}) {
6219 0         0 $delimiter = '{';
6220 0         0 $end_delimiter = '}';
6221             }
6222             elsif (not $octet{']'}) {
6223 0         0 $delimiter = '[';
6224 0         0 $end_delimiter = ']';
6225             }
6226             elsif (not $octet{'>'}) {
6227 0         0 $delimiter = '<';
6228 0         0 $end_delimiter = '>';
6229             }
6230             else {
6231 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6232 0 0       0 if (not $octet{$char}) {
6233 0         0 $delimiter = $char;
6234 0         0 $end_delimiter = $char;
6235 0         0 last;
6236             }
6237             }
6238             }
6239             }
6240              
6241             # count '('
6242 68         97 my $parens = grep { $_ eq '(' } @char;
  253         331  
6243              
6244 68         77 my $left_e = 0;
6245 68         80 my $right_e = 0;
6246 68         193 for (my $i=0; $i <= $#char; $i++) {
6247              
6248             # "\L\u" --> "\u\L"
6249 195 50 33     1102 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6250 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6251             }
6252              
6253             # "\U\l" --> "\l\U"
6254             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6255 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6256             }
6257              
6258             # octal escape sequence
6259             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6260 1         3 $char[$i] = Elatin7::octchr($1);
6261             }
6262              
6263             # hexadecimal escape sequence
6264             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6265 1         3 $char[$i] = Elatin7::hexchr($1);
6266             }
6267              
6268             # \b{...} --> b\{...}
6269             # \B{...} --> B\{...}
6270             # \N{CHARNAME} --> N\{CHARNAME}
6271             # \p{PROPERTY} --> p\{PROPERTY}
6272             # \P{PROPERTY} --> P\{PROPERTY}
6273             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6274 0         0 $char[$i] = $1 . '\\' . $2;
6275             }
6276              
6277             # \p, \P, \X --> p, P, X
6278             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6279 0         0 $char[$i] = $1;
6280             }
6281              
6282 195 50 66     615 if (0) {
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6283             }
6284              
6285             # join separated multiple-octet
6286 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6287 0 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        
6288 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
6289             }
6290             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)) {
6291 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
6292             }
6293             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)) {
6294 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
6295             }
6296             }
6297              
6298             # open character class [...]
6299             elsif ($char[$i] eq '[') {
6300 13         14 my $left = $i;
6301 13 50       37 if ($char[$i+1] eq ']') {
6302 0         0 $i++;
6303             }
6304 13         12 while (1) {
6305 58 50       70 if (++$i > $#char) {
6306 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6307             }
6308 58 100       77 if ($char[$i] eq ']') {
6309 13         13 my $right = $i;
6310              
6311             # [...]
6312 13 50       62 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6313 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6314             }
6315             else {
6316 13         63 splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6317             }
6318              
6319 13         15 $i = $left;
6320 13         30 last;
6321             }
6322             }
6323             }
6324              
6325             # open character class [^...]
6326             elsif ($char[$i] eq '[^') {
6327 0         0 my $left = $i;
6328 0 0       0 if ($char[$i+1] eq ']') {
6329 0         0 $i++;
6330             }
6331 0         0 while (1) {
6332 0 0       0 if (++$i > $#char) {
6333 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6334             }
6335 0 0       0 if ($char[$i] eq ']') {
6336 0         0 my $right = $i;
6337              
6338             # [^...]
6339 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6340 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6341             }
6342             else {
6343 0         0 splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6344             }
6345              
6346 0         0 $i = $left;
6347 0         0 last;
6348             }
6349             }
6350             }
6351              
6352             # rewrite character class or escape character
6353             elsif (my $char = character_class($char[$i],$modifier)) {
6354 7         14 $char[$i] = $char;
6355             }
6356              
6357             # /i modifier
6358             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6359 3 50       5 if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6360 3         6 $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6361             }
6362             else {
6363 0         0 $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
6364             }
6365             }
6366              
6367             # \u \l \U \L \F \Q \E
6368             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6369 0 0       0 if ($right_e < $left_e) {
6370 0         0 $char[$i] = '\\' . $char[$i];
6371             }
6372             }
6373             elsif ($char[$i] eq '\u') {
6374 0         0 $char[$i] = '@{[Elatin7::ucfirst qq<';
6375 0         0 $left_e++;
6376             }
6377             elsif ($char[$i] eq '\l') {
6378 0         0 $char[$i] = '@{[Elatin7::lcfirst qq<';
6379 0         0 $left_e++;
6380             }
6381             elsif ($char[$i] eq '\U') {
6382 0         0 $char[$i] = '@{[Elatin7::uc qq<';
6383 0         0 $left_e++;
6384             }
6385             elsif ($char[$i] eq '\L') {
6386 0         0 $char[$i] = '@{[Elatin7::lc qq<';
6387 0         0 $left_e++;
6388             }
6389             elsif ($char[$i] eq '\F') {
6390 0         0 $char[$i] = '@{[Elatin7::fc qq<';
6391 0         0 $left_e++;
6392             }
6393             elsif ($char[$i] eq '\Q') {
6394 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6395 0         0 $left_e++;
6396             }
6397             elsif ($char[$i] eq '\E') {
6398 0 0       0 if ($right_e < $left_e) {
6399 0         0 $char[$i] = '>]}';
6400 0         0 $right_e++;
6401             }
6402             else {
6403 0         0 $char[$i] = '';
6404             }
6405             }
6406             elsif ($char[$i] eq '\Q') {
6407 0         0 while (1) {
6408 0 0       0 if (++$i > $#char) {
6409 0         0 last;
6410             }
6411 0 0       0 if ($char[$i] eq '\E') {
6412 0         0 last;
6413             }
6414             }
6415             }
6416             elsif ($char[$i] eq '\E') {
6417             }
6418              
6419             # \0 --> \0
6420             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6421             }
6422              
6423             # \g{N}, \g{-N}
6424              
6425             # P.108 Using Simple Patterns
6426             # in Chapter 7: In the World of Regular Expressions
6427             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6428              
6429             # P.221 Capturing
6430             # in Chapter 5: Pattern Matching
6431             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6432              
6433             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6434             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6435             }
6436              
6437             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6438             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6439             }
6440              
6441             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6442             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6443             }
6444              
6445             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6446             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6447             }
6448              
6449             # $0 --> $0
6450             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6451 0 0       0 if ($ignorecase) {
6452 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6453             }
6454             }
6455             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6456 0 0       0 if ($ignorecase) {
6457 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6458             }
6459             }
6460              
6461             # $$ --> $$
6462             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6463             }
6464              
6465             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6466             # $1, $2, $3 --> $1, $2, $3 otherwise
6467             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6468 0         0 $char[$i] = e_capture($1);
6469 0 0       0 if ($ignorecase) {
6470 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6471             }
6472             }
6473             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6474 0         0 $char[$i] = e_capture($1);
6475 0 0       0 if ($ignorecase) {
6476 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6477             }
6478             }
6479              
6480             # $$foo[ ... ] --> $ $foo->[ ... ]
6481             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6482 0         0 $char[$i] = e_capture($1.'->'.$2);
6483 0 0       0 if ($ignorecase) {
6484 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6485             }
6486             }
6487              
6488             # $$foo{ ... } --> $ $foo->{ ... }
6489             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6490 0         0 $char[$i] = e_capture($1.'->'.$2);
6491 0 0       0 if ($ignorecase) {
6492 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6493             }
6494             }
6495              
6496             # $$foo
6497             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6498 0         0 $char[$i] = e_capture($1);
6499 0 0       0 if ($ignorecase) {
6500 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6501             }
6502             }
6503              
6504             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
6505             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6506 4 50       11 if ($ignorecase) {
6507 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
6508             }
6509             else {
6510 4         20 $char[$i] = '@{[Elatin7::PREMATCH()]}';
6511             }
6512             }
6513              
6514             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
6515             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6516 4 50       12 if ($ignorecase) {
6517 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
6518             }
6519             else {
6520 4         18 $char[$i] = '@{[Elatin7::MATCH()]}';
6521             }
6522             }
6523              
6524             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
6525             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6526 3 50       9 if ($ignorecase) {
6527 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
6528             }
6529             else {
6530 3         15 $char[$i] = '@{[Elatin7::POSTMATCH()]}';
6531             }
6532             }
6533              
6534             # ${ foo }
6535             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6536 0 0       0 if ($ignorecase) {
6537 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6538             }
6539             }
6540              
6541             # ${ ... }
6542             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6543 0         0 $char[$i] = e_capture($1);
6544 0 0       0 if ($ignorecase) {
6545 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6546             }
6547             }
6548              
6549             # $scalar or @array
6550             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6551 4         17 $char[$i] = e_string($char[$i]);
6552 4 50       31 if ($ignorecase) {
6553 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6554             }
6555             }
6556              
6557             # quote character before ? + * {
6558             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6559 13 50       45 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6560             }
6561             else {
6562 13         73 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6563             }
6564             }
6565             }
6566              
6567             # make regexp string
6568 68         97 my $prematch = '';
6569 68         81 $modifier =~ tr/i//d;
6570 68 50       199 if ($left_e > $right_e) {
6571 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6572             }
6573 68         693 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6574             }
6575              
6576             #
6577             # escape regexp (s'here'' or s'here''b)
6578             #
6579             sub e_s1_q {
6580 21     21 0 27 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6581 21   100     51 $modifier ||= '';
6582              
6583 21         20 $modifier =~ tr/p//d;
6584 21 50       32 if ($modifier =~ /([adlu])/oxms) {
6585 0         0 my $line = 0;
6586 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6587 0 0       0 if ($filename ne __FILE__) {
6588 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6589 0         0 last;
6590             }
6591             }
6592 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6593             }
6594              
6595 21         35 $slash = 'div';
6596              
6597             # literal null string pattern
6598 21 100       48 if ($string eq '') {
    50          
6599 8         7 $modifier =~ tr/bB//d;
6600 8         7 $modifier =~ tr/i//d;
6601 8         41 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6602             }
6603              
6604             # with /b /B modifier
6605             elsif ($modifier =~ tr/bB//d) {
6606 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6607             }
6608              
6609             # without /b /B modifier
6610             else {
6611 13         22 return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6612             }
6613             }
6614              
6615             #
6616             # escape regexp (s'here'')
6617             #
6618             sub e_s1_qt {
6619 13     13 0 20 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6620              
6621 13 50       24 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6622              
6623             # split regexp
6624 13         208 my @char = $string =~ /\G((?>
6625             [^\\\[\$\@\/] |
6626             [\x00-\xFF] |
6627             \[\^ |
6628             \[\: (?>[a-z]+) \:\] |
6629             \[\:\^ (?>[a-z]+) \:\] |
6630             [\$\@\/] |
6631             \\ (?:$q_char) |
6632             (?:$q_char)
6633             ))/oxmsg;
6634              
6635             # unescape character
6636 13         40 for (my $i=0; $i <= $#char; $i++) {
6637 25 50 33     102 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6638             }
6639              
6640             # open character class [...]
6641 0         0 elsif ($char[$i] eq '[') {
6642 0         0 my $left = $i;
6643 0 0       0 if ($char[$i+1] eq ']') {
6644 0         0 $i++;
6645             }
6646 0         0 while (1) {
6647 0 0       0 if (++$i > $#char) {
6648 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6649             }
6650 0 0       0 if ($char[$i] eq ']') {
6651 0         0 my $right = $i;
6652              
6653             # [...]
6654 0         0 splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6655              
6656 0         0 $i = $left;
6657 0         0 last;
6658             }
6659             }
6660             }
6661              
6662             # open character class [^...]
6663             elsif ($char[$i] eq '[^') {
6664 0         0 my $left = $i;
6665 0 0       0 if ($char[$i+1] eq ']') {
6666 0         0 $i++;
6667             }
6668 0         0 while (1) {
6669 0 0       0 if (++$i > $#char) {
6670 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6671             }
6672 0 0       0 if ($char[$i] eq ']') {
6673 0         0 my $right = $i;
6674              
6675             # [^...]
6676 0         0 splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6677              
6678 0         0 $i = $left;
6679 0         0 last;
6680             }
6681             }
6682             }
6683              
6684             # escape $ @ / and \
6685             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6686 0         0 $char[$i] = '\\' . $char[$i];
6687             }
6688              
6689             # rewrite character class or escape character
6690             elsif (my $char = character_class($char[$i],$modifier)) {
6691 6         10 $char[$i] = $char;
6692             }
6693              
6694             # /i modifier
6695             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6696 0 0       0 if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6697 0         0 $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6698             }
6699             else {
6700 0         0 $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
6701             }
6702             }
6703              
6704             # quote character before ? + * {
6705             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6706 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6707             }
6708             else {
6709 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6710             }
6711             }
6712             }
6713              
6714 13         10 $modifier =~ tr/i//d;
6715 13         16 $delimiter = '/';
6716 13         12 $end_delimiter = '/';
6717 13         13 my $prematch = '';
6718 13         80 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6719             }
6720              
6721             #
6722             # escape regexp (s'here''b)
6723             #
6724             sub e_s1_qb {
6725 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6726              
6727             # split regexp
6728 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6729              
6730             # unescape character
6731 0         0 for (my $i=0; $i <= $#char; $i++) {
6732 0 0       0 if (0) {
    0          
6733             }
6734              
6735             # remain \\
6736 0         0 elsif ($char[$i] eq '\\\\') {
6737             }
6738              
6739             # escape $ @ / and \
6740             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6741 0         0 $char[$i] = '\\' . $char[$i];
6742             }
6743             }
6744              
6745 0         0 $delimiter = '/';
6746 0         0 $end_delimiter = '/';
6747 0         0 my $prematch = '';
6748 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6749             }
6750              
6751             #
6752             # escape regexp (s''here')
6753             #
6754             sub e_s2_q {
6755 16     16 0 18 my($ope,$delimiter,$end_delimiter,$string) = @_;
6756              
6757 16         14 $slash = 'div';
6758              
6759 16         115 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6760 16         37 for (my $i=0; $i <= $#char; $i++) {
6761 9 100       29 if (0) {
    100          
6762             }
6763              
6764             # not escape \\
6765 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6766             }
6767              
6768             # escape $ @ / and \
6769             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6770 5         10 $char[$i] = '\\' . $char[$i];
6771             }
6772             }
6773              
6774 16         44 return join '', $ope, $delimiter, @char, $end_delimiter;
6775             }
6776              
6777             #
6778             # escape regexp (s/here/and here/modifier)
6779             #
6780             sub e_sub {
6781 97     97 0 344 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6782 97   100     314 $modifier ||= '';
6783              
6784 97         135 $modifier =~ tr/p//d;
6785 97 50       219 if ($modifier =~ /([adlu])/oxms) {
6786 0         0 my $line = 0;
6787 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6788 0 0       0 if ($filename ne __FILE__) {
6789 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6790 0         0 last;
6791             }
6792             }
6793 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6794             }
6795              
6796 97 100       181 if ($variable eq '') {
6797 36         27 $variable = '$_';
6798 36         40 $bind_operator = ' =~ ';
6799             }
6800              
6801 97         94 $slash = 'div';
6802              
6803             # P.128 Start of match (or end of previous match): \G
6804             # P.130 Advanced Use of \G with Perl
6805             # in Chapter 3: Overview of Regular Expression Features and Flavors
6806             # P.312 Iterative Matching: Scalar Context, with /g
6807             # in Chapter 7: Perl
6808             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6809              
6810             # P.181 Where You Left Off: The \G Assertion
6811             # in Chapter 5: Pattern Matching
6812             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6813              
6814             # P.220 Where You Left Off: The \G Assertion
6815             # in Chapter 5: Pattern Matching
6816             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6817              
6818 97         107 my $e_modifier = $modifier =~ tr/e//d;
6819 97         97 my $r_modifier = $modifier =~ tr/r//d;
6820              
6821 97         95 my $my = '';
6822 97 50       195 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6823 0         0 $my = $variable;
6824 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6825 0         0 $variable =~ s/ = .+ \z//oxms;
6826             }
6827              
6828 97         166 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6829 97         127 $variable_basename =~ s/ \s+ \z//oxms;
6830              
6831             # quote replacement string
6832 97         97 my $e_replacement = '';
6833 97 100       181 if ($e_modifier >= 1) {
6834 17         24 $e_replacement = e_qq('', '', '', $replacement);
6835 17         22 $e_modifier--;
6836             }
6837             else {
6838 80 100       128 if ($delimiter2 eq "'") {
6839 16         28 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6840             }
6841             else {
6842 64         128 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6843             }
6844             }
6845              
6846 97         125 my $sub = '';
6847              
6848             # with /r
6849 97 100       161 if ($r_modifier) {
6850 8 100       14 if (0) {
6851             }
6852              
6853             # s///gr without multibyte anchoring
6854 0         0 elsif ($modifier =~ /g/oxms) {
6855 4 50       13 $sub = sprintf(
6856             # 1 2 3 4 5
6857             q,
6858              
6859             $variable, # 1
6860             ($delimiter1 eq "'") ? # 2
6861             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6862             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6863             $s_matched, # 3
6864             $e_replacement, # 4
6865             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 5
6866             );
6867             }
6868              
6869             # s///r
6870             else {
6871              
6872 4         2 my $prematch = q{$`};
6873              
6874 4 50       12 $sub = sprintf(
6875             # 1 2 3 4 5 6 7
6876             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin7::re_r=%s; %s"%s$Latin7::re_r$'" } : %s>,
6877              
6878             $variable, # 1
6879             ($delimiter1 eq "'") ? # 2
6880             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6881             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6882             $s_matched, # 3
6883             $e_replacement, # 4
6884             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 5
6885             $prematch, # 6
6886             $variable, # 7
6887             );
6888             }
6889              
6890             # $var !~ s///r doesn't make sense
6891 8 50       15 if ($bind_operator =~ / !~ /oxms) {
6892 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6893             }
6894             }
6895              
6896             # without /r
6897             else {
6898 89 100       165 if (0) {
6899             }
6900              
6901             # s///g without multibyte anchoring
6902 0         0 elsif ($modifier =~ /g/oxms) {
6903 22 100       63 $sub = sprintf(
    100          
6904             # 1 2 3 4 5 6 7 8
6905             q,
6906              
6907             $variable, # 1
6908             ($delimiter1 eq "'") ? # 2
6909             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6910             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6911             $s_matched, # 3
6912             $e_replacement, # 4
6913             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 5
6914             $variable, # 6
6915             $variable, # 7
6916             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6917             );
6918             }
6919              
6920             # s///
6921             else {
6922              
6923 67         74 my $prematch = q{$`};
6924              
6925 67 100       296 $sub = sprintf(
    100          
6926              
6927             ($bind_operator =~ / =~ /oxms) ?
6928              
6929             # 1 2 3 4 5 6 7 8
6930             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin7::re_r=%s; %s%s="%s$Latin7::re_r$'"; 1 } : undef> :
6931              
6932             # 1 2 3 4 5 6 7 8
6933             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin7::re_r=%s; %s%s="%s$Latin7::re_r$'"; undef }>,
6934              
6935             $variable, # 1
6936             $bind_operator, # 2
6937             ($delimiter1 eq "'") ? # 3
6938             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6939             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6940             $s_matched, # 4
6941             $e_replacement, # 5
6942             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 6
6943             $variable, # 7
6944             $prematch, # 8
6945             );
6946             }
6947             }
6948              
6949             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6950 97 50       223 if ($my ne '') {
6951 0         0 $sub = "($my, $sub)[1]";
6952             }
6953              
6954             # clear s/// variable
6955 97         94 $sub_variable = '';
6956 97         84 $bind_operator = '';
6957              
6958 97         599 return $sub;
6959             }
6960              
6961             #
6962             # escape regexp of split qr//
6963             #
6964             sub e_split {
6965 74     74 0 187 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6966 74   100     290 $modifier ||= '';
6967              
6968 74         90 $modifier =~ tr/p//d;
6969 74 50       279 if ($modifier =~ /([adlu])/oxms) {
6970 0         0 my $line = 0;
6971 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6972 0 0       0 if ($filename ne __FILE__) {
6973 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6974 0         0 last;
6975             }
6976             }
6977 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6978             }
6979              
6980 74         80 $slash = 'div';
6981              
6982             # /b /B modifier
6983 74 50       132 if ($modifier =~ tr/bB//d) {
6984 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6985             }
6986              
6987 74 50       136 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6988 74         249 my $metachar = qr/[\@\\|[\]{^]/oxms;
6989              
6990             # split regexp
6991 74         7783 my @char = $string =~ /\G((?>
6992             [^\\\$\@\[\(] |
6993             \\x (?>[0-9A-Fa-f]{1,2}) |
6994             \\ (?>[0-7]{2,3}) |
6995             \\c [\x40-\x5F] |
6996             \\x\{ (?>[0-9A-Fa-f]+) \} |
6997             \\o\{ (?>[0-7]+) \} |
6998             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6999             \\ $q_char |
7000             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7001             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7002             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7003             [\$\@] $qq_variable |
7004             \$ (?>\s* [0-9]+) |
7005             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7006             \$ \$ (?![\w\{]) |
7007             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7008             \[\^ |
7009             \[\: (?>[a-z]+) :\] |
7010             \[\:\^ (?>[a-z]+) :\] |
7011             \(\? |
7012             $q_char
7013             ))/oxmsg;
7014              
7015 74         216 my $left_e = 0;
7016 74         70 my $right_e = 0;
7017 74         246 for (my $i=0; $i <= $#char; $i++) {
7018              
7019             # "\L\u" --> "\u\L"
7020 249 50 33     1326 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7021 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7022             }
7023              
7024             # "\U\l" --> "\l\U"
7025             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7026 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7027             }
7028              
7029             # octal escape sequence
7030             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7031 1         3 $char[$i] = Elatin7::octchr($1);
7032             }
7033              
7034             # hexadecimal escape sequence
7035             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7036 1         3 $char[$i] = Elatin7::hexchr($1);
7037             }
7038              
7039             # \b{...} --> b\{...}
7040             # \B{...} --> B\{...}
7041             # \N{CHARNAME} --> N\{CHARNAME}
7042             # \p{PROPERTY} --> p\{PROPERTY}
7043             # \P{PROPERTY} --> P\{PROPERTY}
7044             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7045 0         0 $char[$i] = $1 . '\\' . $2;
7046             }
7047              
7048             # \p, \P, \X --> p, P, X
7049             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7050 0         0 $char[$i] = $1;
7051             }
7052              
7053 249 50 100     689 if (0) {
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7054             }
7055              
7056             # join separated multiple-octet
7057 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7058 0 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        
7059 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
7060             }
7061             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)) {
7062 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
7063             }
7064             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)) {
7065 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
7066             }
7067             }
7068              
7069             # open character class [...]
7070             elsif ($char[$i] eq '[') {
7071 3         3 my $left = $i;
7072 3 50       7 if ($char[$i+1] eq ']') {
7073 0         0 $i++;
7074             }
7075 3         2 while (1) {
7076 7 50       17 if (++$i > $#char) {
7077 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7078             }
7079 7 100       11 if ($char[$i] eq ']') {
7080 3         2 my $right = $i;
7081              
7082             # [...]
7083 3 50       15 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7084 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7085             }
7086             else {
7087 3         8 splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
7088             }
7089              
7090 3         3 $i = $left;
7091 3         7 last;
7092             }
7093             }
7094             }
7095              
7096             # open character class [^...]
7097             elsif ($char[$i] eq '[^') {
7098 0         0 my $left = $i;
7099 0 0       0 if ($char[$i+1] eq ']') {
7100 0         0 $i++;
7101             }
7102 0         0 while (1) {
7103 0 0       0 if (++$i > $#char) {
7104 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7105             }
7106 0 0       0 if ($char[$i] eq ']') {
7107 0         0 my $right = $i;
7108              
7109             # [^...]
7110 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7111 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7112             }
7113             else {
7114 0         0 splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7115             }
7116              
7117 0         0 $i = $left;
7118 0         0 last;
7119             }
7120             }
7121             }
7122              
7123             # rewrite character class or escape character
7124             elsif (my $char = character_class($char[$i],$modifier)) {
7125 1         3 $char[$i] = $char;
7126             }
7127              
7128             # P.794 29.2.161. split
7129             # in Chapter 29: Functions
7130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7131              
7132             # P.951 split
7133             # in Chapter 27: Functions
7134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7135              
7136             # said "The //m modifier is assumed when you split on the pattern /^/",
7137             # but perl5.008 is not so. Therefore, this software adds //m.
7138             # (and so on)
7139              
7140             # split(m/^/) --> split(m/^/m)
7141             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7142 7         41 $modifier .= 'm';
7143             }
7144              
7145             # /i modifier
7146             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
7147 0 0       0 if (CORE::length(Elatin7::fc($char[$i])) == 1) {
7148 0         0 $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
7149             }
7150             else {
7151 0         0 $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
7152             }
7153             }
7154              
7155             # \u \l \U \L \F \Q \E
7156             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7157 0 0       0 if ($right_e < $left_e) {
7158 0         0 $char[$i] = '\\' . $char[$i];
7159             }
7160             }
7161             elsif ($char[$i] eq '\u') {
7162 0         0 $char[$i] = '@{[Elatin7::ucfirst qq<';
7163 0         0 $left_e++;
7164             }
7165             elsif ($char[$i] eq '\l') {
7166 0         0 $char[$i] = '@{[Elatin7::lcfirst qq<';
7167 0         0 $left_e++;
7168             }
7169             elsif ($char[$i] eq '\U') {
7170 0         0 $char[$i] = '@{[Elatin7::uc qq<';
7171 0         0 $left_e++;
7172             }
7173             elsif ($char[$i] eq '\L') {
7174 0         0 $char[$i] = '@{[Elatin7::lc qq<';
7175 0         0 $left_e++;
7176             }
7177             elsif ($char[$i] eq '\F') {
7178 0         0 $char[$i] = '@{[Elatin7::fc qq<';
7179 0         0 $left_e++;
7180             }
7181             elsif ($char[$i] eq '\Q') {
7182 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7183 0         0 $left_e++;
7184             }
7185             elsif ($char[$i] eq '\E') {
7186 0 0       0 if ($right_e < $left_e) {
7187 0         0 $char[$i] = '>]}';
7188 0         0 $right_e++;
7189             }
7190             else {
7191 0         0 $char[$i] = '';
7192             }
7193             }
7194             elsif ($char[$i] eq '\Q') {
7195 0         0 while (1) {
7196 0 0       0 if (++$i > $#char) {
7197 0         0 last;
7198             }
7199 0 0       0 if ($char[$i] eq '\E') {
7200 0         0 last;
7201             }
7202             }
7203             }
7204             elsif ($char[$i] eq '\E') {
7205             }
7206              
7207             # $0 --> $0
7208             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7209 0 0       0 if ($ignorecase) {
7210 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7211             }
7212             }
7213             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7214 0 0       0 if ($ignorecase) {
7215 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7216             }
7217             }
7218              
7219             # $$ --> $$
7220             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7221             }
7222              
7223             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7224             # $1, $2, $3 --> $1, $2, $3 otherwise
7225             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7226 0         0 $char[$i] = e_capture($1);
7227 0 0       0 if ($ignorecase) {
7228 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7229             }
7230             }
7231             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7232 0         0 $char[$i] = e_capture($1);
7233 0 0       0 if ($ignorecase) {
7234 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7235             }
7236             }
7237              
7238             # $$foo[ ... ] --> $ $foo->[ ... ]
7239             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7240 0         0 $char[$i] = e_capture($1.'->'.$2);
7241 0 0       0 if ($ignorecase) {
7242 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7243             }
7244             }
7245              
7246             # $$foo{ ... } --> $ $foo->{ ... }
7247             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7248 0         0 $char[$i] = e_capture($1.'->'.$2);
7249 0 0       0 if ($ignorecase) {
7250 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7251             }
7252             }
7253              
7254             # $$foo
7255             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7256 0         0 $char[$i] = e_capture($1);
7257 0 0       0 if ($ignorecase) {
7258 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7259             }
7260             }
7261              
7262             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
7263             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7264 12 50       17 if ($ignorecase) {
7265 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
7266             }
7267             else {
7268 12         68 $char[$i] = '@{[Elatin7::PREMATCH()]}';
7269             }
7270             }
7271              
7272             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
7273             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7274 12 50       18 if ($ignorecase) {
7275 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
7276             }
7277             else {
7278 12         69 $char[$i] = '@{[Elatin7::MATCH()]}';
7279             }
7280             }
7281              
7282             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
7283             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7284 9 50       15 if ($ignorecase) {
7285 0         0 $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
7286             }
7287             else {
7288 9         53 $char[$i] = '@{[Elatin7::POSTMATCH()]}';
7289             }
7290             }
7291              
7292             # ${ foo }
7293             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7294 0 0       0 if ($ignorecase) {
7295 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $1 . ')]}';
7296             }
7297             }
7298              
7299             # ${ ... }
7300             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7301 0         0 $char[$i] = e_capture($1);
7302 0 0       0 if ($ignorecase) {
7303 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7304             }
7305             }
7306              
7307             # $scalar or @array
7308             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7309 3         5 $char[$i] = e_string($char[$i]);
7310 3 50       18 if ($ignorecase) {
7311 0         0 $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7312             }
7313             }
7314              
7315             # quote character before ? + * {
7316             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7317 1 50       7 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7318             }
7319             else {
7320 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7321             }
7322             }
7323             }
7324              
7325             # make regexp string
7326 74         88 $modifier =~ tr/i//d;
7327 74 50       141 if ($left_e > $right_e) {
7328 0         0 return join '', 'Elatin7::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7329             }
7330 74         606 return join '', 'Elatin7::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7331             }
7332              
7333             #
7334             # escape regexp of split qr''
7335             #
7336             sub e_split_q {
7337 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7338 0   0       $modifier ||= '';
7339              
7340 0           $modifier =~ tr/p//d;
7341 0 0         if ($modifier =~ /([adlu])/oxms) {
7342 0           my $line = 0;
7343 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7344 0 0         if ($filename ne __FILE__) {
7345 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7346 0           last;
7347             }
7348             }
7349 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7350             }
7351              
7352 0           $slash = 'div';
7353              
7354             # /b /B modifier
7355 0 0         if ($modifier =~ tr/bB//d) {
7356 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7357             }
7358              
7359 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7360              
7361             # split regexp
7362 0           my @char = $string =~ /\G((?>
7363             [^\\\[] |
7364             [\x00-\xFF] |
7365             \[\^ |
7366             \[\: (?>[a-z]+) \:\] |
7367             \[\:\^ (?>[a-z]+) \:\] |
7368             \\ (?:$q_char) |
7369             (?:$q_char)
7370             ))/oxmsg;
7371              
7372             # unescape character
7373 0           for (my $i=0; $i <= $#char; $i++) {
7374 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7375             }
7376              
7377             # open character class [...]
7378 0           elsif ($char[$i] eq '[') {
7379 0           my $left = $i;
7380 0 0         if ($char[$i+1] eq ']') {
7381 0           $i++;
7382             }
7383 0           while (1) {
7384 0 0         if (++$i > $#char) {
7385 0           die __FILE__, ": Unmatched [] in regexp\n";
7386             }
7387 0 0         if ($char[$i] eq ']') {
7388 0           my $right = $i;
7389              
7390             # [...]
7391 0           splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
7392              
7393 0           $i = $left;
7394 0           last;
7395             }
7396             }
7397             }
7398              
7399             # open character class [^...]
7400             elsif ($char[$i] eq '[^') {
7401 0           my $left = $i;
7402 0 0         if ($char[$i+1] eq ']') {
7403 0           $i++;
7404             }
7405 0           while (1) {
7406 0 0         if (++$i > $#char) {
7407 0           die __FILE__, ": Unmatched [] in regexp\n";
7408             }
7409 0 0         if ($char[$i] eq ']') {
7410 0           my $right = $i;
7411              
7412             # [^...]
7413 0           splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7414              
7415 0           $i = $left;
7416 0           last;
7417             }
7418             }
7419             }
7420              
7421             # rewrite character class or escape character
7422             elsif (my $char = character_class($char[$i],$modifier)) {
7423 0           $char[$i] = $char;
7424             }
7425              
7426             # split(m/^/) --> split(m/^/m)
7427             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7428 0           $modifier .= 'm';
7429             }
7430              
7431             # /i modifier
7432             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
7433 0 0         if (CORE::length(Elatin7::fc($char[$i])) == 1) {
7434 0           $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
7435             }
7436             else {
7437 0           $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
7438             }
7439             }
7440              
7441             # quote character before ? + * {
7442             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7443 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7444             }
7445             else {
7446 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7447             }
7448             }
7449             }
7450              
7451 0           $modifier =~ tr/i//d;
7452 0           return join '', 'Elatin7::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7453             }
7454              
7455             #
7456             # instead of Carp::carp
7457             #
7458             sub carp {
7459 0     0 0   my($package,$filename,$line) = caller(1);
7460 0           print STDERR "@_ at $filename line $line.\n";
7461             }
7462              
7463             #
7464             # instead of Carp::croak
7465             #
7466             sub croak {
7467 0     0 0   my($package,$filename,$line) = caller(1);
7468 0           print STDERR "@_ at $filename line $line.\n";
7469 0           die "\n";
7470             }
7471              
7472             #
7473             # instead of Carp::cluck
7474             #
7475             sub cluck {
7476 0     0 0   my $i = 0;
7477 0           my @cluck = ();
7478 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7479 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7480 0           $i++;
7481             }
7482 0           print STDERR CORE::reverse @cluck;
7483 0           print STDERR "\n";
7484 0           carp @_;
7485             }
7486              
7487             #
7488             # instead of Carp::confess
7489             #
7490             sub confess {
7491 0     0 0   my $i = 0;
7492 0           my @confess = ();
7493 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7494 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7495 0           $i++;
7496             }
7497 0           print STDERR CORE::reverse @confess;
7498 0           print STDERR "\n";
7499 0           croak @_;
7500             }
7501              
7502             1;
7503              
7504             __END__