File Coverage

blib/lib/Egreek.pm
Criterion Covered Total %
statement 905 3196 28.3
branch 968 2742 35.3
condition 98 355 27.6
subroutine 52 110 47.2
pod 7 74 9.4
total 2030 6477 31.3


line stmt bran cond sub pod time code
1             package Egreek;
2 204     204   1193 use strict;
  204         331  
  204         6913  
3             ######################################################################
4             #
5             # Egreek - Run-time routines for Greek.pm
6             #
7             # http://search.cpan.org/dist/Char-Greek/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   4000 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         848  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 204     204   1117 use vars qw($VERSION);
  204         394  
  204         40136  
28             $VERSION = '1.15';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1990 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         417 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         42562 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44              
45             # instead of utf8.pm
46 204     204   17883 CORE::eval q{
  204     204   1546  
  204     58   394  
  204         29985  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 204 50       103024 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     0 0 0 my($name) = @_;
78              
79 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
80 0         0 return $name;
81             }
82             elsif (Egreek::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Egreek::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 0         0 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 0   0 0 0 if (defined $_[1]) {
117 204     204   1500 no strict qw(refs);
  204         576  
  204         17227  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   1179 no strict qw(refs);
  204     0   405  
  204         47573  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x00-\xFF]};
153 204     204   1361 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         1038  
  204         29629  
154 204     204   1439 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         378  
  204         418283  
155              
156             #
157             # Greek character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Greek case conversion
163             #
164             my %lc = ();
165             @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)} =
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 %uc = ();
168             @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)} =
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             my %fc = ();
171             @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)} =
172             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);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Egreek \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xB6" => "\xDC", # GREEK LETTER ALPHA WITH TONOS
185             "\xB8" => "\xDD", # GREEK LETTER EPSILON WITH TONOS
186             "\xB9" => "\xDE", # GREEK LETTER ETA WITH TONOS
187             "\xBA" => "\xDF", # GREEK LETTER IOTA WITH TONOS
188             "\xBC" => "\xFC", # GREEK LETTER OMICRON WITH TONOS
189             "\xBE" => "\xFD", # GREEK LETTER UPSILON WITH TONOS
190             "\xBF" => "\xFE", # GREEK LETTER OMEGA WITH TONOS
191             "\xC1" => "\xE1", # GREEK LETTER ALPHA
192             "\xC2" => "\xE2", # GREEK LETTER BETA
193             "\xC3" => "\xE3", # GREEK LETTER GAMMA
194             "\xC4" => "\xE4", # GREEK LETTER DELTA
195             "\xC5" => "\xE5", # GREEK LETTER EPSILON
196             "\xC6" => "\xE6", # GREEK LETTER ZETA
197             "\xC7" => "\xE7", # GREEK LETTER ETA
198             "\xC8" => "\xE8", # GREEK LETTER THETA
199             "\xC9" => "\xE9", # GREEK LETTER IOTA
200             "\xCA" => "\xEA", # GREEK LETTER KAPPA
201             "\xCB" => "\xEB", # GREEK LETTER LAMDA
202             "\xCC" => "\xEC", # GREEK LETTER MU
203             "\xCD" => "\xED", # GREEK LETTER NU
204             "\xCE" => "\xEE", # GREEK LETTER XI
205             "\xCF" => "\xEF", # GREEK LETTER OMICRON
206             "\xD0" => "\xF0", # GREEK LETTER PI
207             "\xD1" => "\xF1", # GREEK LETTER RHO
208             "\xD3" => "\xF3", # GREEK LETTER SIGMA
209             "\xD4" => "\xF4", # GREEK LETTER TAU
210             "\xD5" => "\xF5", # GREEK LETTER UPSILON
211             "\xD6" => "\xF6", # GREEK LETTER PHI
212             "\xD7" => "\xF7", # GREEK LETTER CHI
213             "\xD8" => "\xF8", # GREEK LETTER PSI
214             "\xD9" => "\xF9", # GREEK LETTER OMEGA
215             "\xDA" => "\xFA", # GREEK LETTER IOTA WITH DIALYTIKA
216             "\xDB" => "\xFB", # GREEK LETTER UPSILON WITH DIALYTIKA
217             );
218              
219             %uc = (%uc,
220             "\xDC" => "\xB6", # GREEK LETTER ALPHA WITH TONOS
221             "\xDD" => "\xB8", # GREEK LETTER EPSILON WITH TONOS
222             "\xDE" => "\xB9", # GREEK LETTER ETA WITH TONOS
223             "\xDF" => "\xBA", # GREEK LETTER IOTA WITH TONOS
224             "\xE1" => "\xC1", # GREEK LETTER ALPHA
225             "\xE2" => "\xC2", # GREEK LETTER BETA
226             "\xE3" => "\xC3", # GREEK LETTER GAMMA
227             "\xE4" => "\xC4", # GREEK LETTER DELTA
228             "\xE5" => "\xC5", # GREEK LETTER EPSILON
229             "\xE6" => "\xC6", # GREEK LETTER ZETA
230             "\xE7" => "\xC7", # GREEK LETTER ETA
231             "\xE8" => "\xC8", # GREEK LETTER THETA
232             "\xE9" => "\xC9", # GREEK LETTER IOTA
233             "\xEA" => "\xCA", # GREEK LETTER KAPPA
234             "\xEB" => "\xCB", # GREEK LETTER LAMDA
235             "\xEC" => "\xCC", # GREEK LETTER MU
236             "\xED" => "\xCD", # GREEK LETTER NU
237             "\xEE" => "\xCE", # GREEK LETTER XI
238             "\xEF" => "\xCF", # GREEK LETTER OMICRON
239             "\xF0" => "\xD0", # GREEK LETTER PI
240             "\xF1" => "\xD1", # GREEK LETTER RHO
241             "\xF3" => "\xD3", # GREEK LETTER SIGMA
242             "\xF4" => "\xD4", # GREEK LETTER TAU
243             "\xF5" => "\xD5", # GREEK LETTER UPSILON
244             "\xF6" => "\xD6", # GREEK LETTER PHI
245             "\xF7" => "\xD7", # GREEK LETTER CHI
246             "\xF8" => "\xD8", # GREEK LETTER PSI
247             "\xF9" => "\xD9", # GREEK LETTER OMEGA
248             "\xFA" => "\xDA", # GREEK LETTER IOTA WITH DIALYTIKA
249             "\xFB" => "\xDB", # GREEK LETTER UPSILON WITH DIALYTIKA
250             "\xFC" => "\xBC", # GREEK LETTER OMICRON WITH TONOS
251             "\xFD" => "\xBE", # GREEK LETTER UPSILON WITH TONOS
252             "\xFE" => "\xBF", # GREEK LETTER OMEGA WITH TONOS
253             );
254              
255             %fc = (%fc,
256             "\xB6" => "\xDC", # GREEK CAPITAL LETTER ALPHA WITH TONOS --> GREEK SMALL LETTER ALPHA WITH TONOS
257             "\xB8" => "\xDD", # GREEK CAPITAL LETTER EPSILON WITH TONOS --> GREEK SMALL LETTER EPSILON WITH TONOS
258             "\xB9" => "\xDE", # GREEK CAPITAL LETTER ETA WITH TONOS --> GREEK SMALL LETTER ETA WITH TONOS
259             "\xBA" => "\xDF", # GREEK CAPITAL LETTER IOTA WITH TONOS --> GREEK SMALL LETTER IOTA WITH TONOS
260             "\xBC" => "\xFC", # GREEK CAPITAL LETTER OMICRON WITH TONOS --> GREEK SMALL LETTER OMICRON WITH TONOS
261             "\xBE" => "\xFD", # GREEK CAPITAL LETTER UPSILON WITH TONOS --> GREEK SMALL LETTER UPSILON WITH TONOS
262             "\xBF" => "\xFE", # GREEK CAPITAL LETTER OMEGA WITH TONOS --> GREEK SMALL LETTER OMEGA WITH TONOS
263             "\xC1" => "\xE1", # GREEK CAPITAL LETTER ALPHA --> GREEK SMALL LETTER ALPHA
264             "\xC2" => "\xE2", # GREEK CAPITAL LETTER BETA --> GREEK SMALL LETTER BETA
265             "\xC3" => "\xE3", # GREEK CAPITAL LETTER GAMMA --> GREEK SMALL LETTER GAMMA
266             "\xC4" => "\xE4", # GREEK CAPITAL LETTER DELTA --> GREEK SMALL LETTER DELTA
267             "\xC5" => "\xE5", # GREEK CAPITAL LETTER EPSILON --> GREEK SMALL LETTER EPSILON
268             "\xC6" => "\xE6", # GREEK CAPITAL LETTER ZETA --> GREEK SMALL LETTER ZETA
269             "\xC7" => "\xE7", # GREEK CAPITAL LETTER ETA --> GREEK SMALL LETTER ETA
270             "\xC8" => "\xE8", # GREEK CAPITAL LETTER THETA --> GREEK SMALL LETTER THETA
271             "\xC9" => "\xE9", # GREEK CAPITAL LETTER IOTA --> GREEK SMALL LETTER IOTA
272             "\xCA" => "\xEA", # GREEK CAPITAL LETTER KAPPA --> GREEK SMALL LETTER KAPPA
273             "\xCB" => "\xEB", # GREEK CAPITAL LETTER LAMDA --> GREEK SMALL LETTER LAMDA
274             "\xCC" => "\xEC", # GREEK CAPITAL LETTER MU --> GREEK SMALL LETTER MU
275             "\xCD" => "\xED", # GREEK CAPITAL LETTER NU --> GREEK SMALL LETTER NU
276             "\xCE" => "\xEE", # GREEK CAPITAL LETTER XI --> GREEK SMALL LETTER XI
277             "\xCF" => "\xEF", # GREEK CAPITAL LETTER OMICRON --> GREEK SMALL LETTER OMICRON
278             "\xD0" => "\xF0", # GREEK CAPITAL LETTER PI --> GREEK SMALL LETTER PI
279             "\xD1" => "\xF1", # GREEK CAPITAL LETTER RHO --> GREEK SMALL LETTER RHO
280             "\xD3" => "\xF3", # GREEK CAPITAL LETTER SIGMA --> GREEK SMALL LETTER SIGMA
281             "\xD4" => "\xF4", # GREEK CAPITAL LETTER TAU --> GREEK SMALL LETTER TAU
282             "\xD5" => "\xF5", # GREEK CAPITAL LETTER UPSILON --> GREEK SMALL LETTER UPSILON
283             "\xD6" => "\xF6", # GREEK CAPITAL LETTER PHI --> GREEK SMALL LETTER PHI
284             "\xD7" => "\xF7", # GREEK CAPITAL LETTER CHI --> GREEK SMALL LETTER CHI
285             "\xD8" => "\xF8", # GREEK CAPITAL LETTER PSI --> GREEK SMALL LETTER PSI
286             "\xD9" => "\xF9", # GREEK CAPITAL LETTER OMEGA --> GREEK SMALL LETTER OMEGA
287             "\xDA" => "\xFA", # GREEK CAPITAL LETTER IOTA WITH DIALYTIKA --> GREEK SMALL LETTER IOTA WITH DIALYTIKA
288             "\xDB" => "\xFB", # GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA --> GREEK SMALL LETTER UPSILON WITH DIALYTIKA
289             "\xF2" => "\xF3", # GREEK SMALL LETTER FINAL SIGMA --> GREEK SMALL LETTER SIGMA
290             );
291             }
292              
293             else {
294             croak "Don't know my package name '@{[__PACKAGE__]}'";
295             }
296              
297             #
298             # @ARGV wildcard globbing
299             #
300             sub import {
301              
302 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
303 0         0 my @argv = ();
304 0         0 for (@ARGV) {
305              
306             # has space
307 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
308 0 0       0 if (my @glob = Egreek::glob(qq{"$_"})) {
309 0         0 push @argv, @glob;
310             }
311             else {
312 0         0 push @argv, $_;
313             }
314             }
315              
316             # has wildcard metachar
317             elsif (/\A (?:$q_char)*? [*?] /oxms) {
318 0 0       0 if (my @glob = Egreek::glob($_)) {
319 0         0 push @argv, @glob;
320             }
321             else {
322 0         0 push @argv, $_;
323             }
324             }
325              
326             # no wildcard globbing
327             else {
328 0         0 push @argv, $_;
329             }
330             }
331 0         0 @ARGV = @argv;
332             }
333              
334 0         0 *Char::ord = \&Greek::ord;
335 0         0 *Char::ord_ = \&Greek::ord_;
336 0         0 *Char::reverse = \&Greek::reverse;
337 0         0 *Char::getc = \&Greek::getc;
338 0         0 *Char::length = \&Greek::length;
339 0         0 *Char::substr = \&Greek::substr;
340 0         0 *Char::index = \&Greek::index;
341 0         0 *Char::rindex = \&Greek::rindex;
342 0         0 *Char::eval = \&Greek::eval;
343 0         0 *Char::escape = \&Greek::escape;
344 0         0 *Char::escape_token = \&Greek::escape_token;
345 0         0 *Char::escape_script = \&Greek::escape_script;
346             }
347              
348             # P.230 Care with Prototypes
349             # in Chapter 6: Subroutines
350             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
351             #
352             # If you aren't careful, you can get yourself into trouble with prototypes.
353             # But if you are careful, you can do a lot of neat things with them. This is
354             # all very powerful, of course, and should only be used in moderation to make
355             # the world a better place.
356              
357             # P.332 Care with Prototypes
358             # in Chapter 7: Subroutines
359             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
360             #
361             # If you aren't careful, you can get yourself into trouble with prototypes.
362             # But if you are careful, you can do a lot of neat things with them. This is
363             # all very powerful, of course, and should only be used in moderation to make
364             # the world a better place.
365              
366             #
367             # Prototypes of subroutines
368             #
369       0     sub unimport {}
370             sub Egreek::split(;$$$);
371             sub Egreek::tr($$$$;$);
372             sub Egreek::chop(@);
373             sub Egreek::index($$;$);
374             sub Egreek::rindex($$;$);
375             sub Egreek::lcfirst(@);
376             sub Egreek::lcfirst_();
377             sub Egreek::lc(@);
378             sub Egreek::lc_();
379             sub Egreek::ucfirst(@);
380             sub Egreek::ucfirst_();
381             sub Egreek::uc(@);
382             sub Egreek::uc_();
383             sub Egreek::fc(@);
384             sub Egreek::fc_();
385             sub Egreek::ignorecase;
386             sub Egreek::classic_character_class;
387             sub Egreek::capture;
388             sub Egreek::chr(;$);
389             sub Egreek::chr_();
390             sub Egreek::glob($);
391             sub Egreek::glob_();
392              
393             sub Greek::ord(;$);
394             sub Greek::ord_();
395             sub Greek::reverse(@);
396             sub Greek::getc(;*@);
397             sub Greek::length(;$);
398             sub Greek::substr($$;$$);
399             sub Greek::index($$;$);
400             sub Greek::rindex($$;$);
401             sub Greek::escape(;$);
402              
403             #
404             # Regexp work
405             #
406 204         19758 use vars qw(
407             $re_a
408             $re_t
409             $re_n
410             $re_r
411 204     204   2128 );
  204         466  
412              
413             #
414             # Character class
415             #
416 204         2393288 use vars qw(
417             $dot
418             $dot_s
419             $eD
420             $eS
421             $eW
422             $eH
423             $eV
424             $eR
425             $eN
426             $not_alnum
427             $not_alpha
428             $not_ascii
429             $not_blank
430             $not_cntrl
431             $not_digit
432             $not_graph
433             $not_lower
434             $not_lower_i
435             $not_print
436             $not_punct
437             $not_space
438             $not_upper
439             $not_upper_i
440             $not_word
441             $not_xdigit
442             $eb
443             $eB
444 204     204   1237 );
  204         432  
445              
446             ${Egreek::dot} = qr{(?>[^\x0A])};
447             ${Egreek::dot_s} = qr{(?>[\x00-\xFF])};
448             ${Egreek::eD} = qr{(?>[^0-9])};
449              
450             # Vertical tabs are now whitespace
451             # \s in a regex now matches a vertical tab in all circumstances.
452             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
453             # ${Egreek::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
454             # ${Egreek::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
455             ${Egreek::eS} = qr{(?>[^\s])};
456              
457             ${Egreek::eW} = qr{(?>[^0-9A-Z_a-z])};
458             ${Egreek::eH} = qr{(?>[^\x09\x20])};
459             ${Egreek::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
460             ${Egreek::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
461             ${Egreek::eN} = qr{(?>[^\x0A])};
462             ${Egreek::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
463             ${Egreek::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
464             ${Egreek::not_ascii} = qr{(?>[^\x00-\x7F])};
465             ${Egreek::not_blank} = qr{(?>[^\x09\x20])};
466             ${Egreek::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
467             ${Egreek::not_digit} = qr{(?>[^\x30-\x39])};
468             ${Egreek::not_graph} = qr{(?>[^\x21-\x7F])};
469             ${Egreek::not_lower} = qr{(?>[^\x61-\x7A])};
470             ${Egreek::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
471             # ${Egreek::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
472             ${Egreek::not_print} = qr{(?>[^\x20-\x7F])};
473             ${Egreek::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
474             ${Egreek::not_space} = qr{(?>[^\s\x0B])};
475             ${Egreek::not_upper} = qr{(?>[^\x41-\x5A])};
476             ${Egreek::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
477             # ${Egreek::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
478             ${Egreek::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
479             ${Egreek::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
480             ${Egreek::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))};
481             ${Egreek::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]))};
482              
483             # avoid: Name "Egreek::foo" used only once: possible typo at here.
484             ${Egreek::dot} = ${Egreek::dot};
485             ${Egreek::dot_s} = ${Egreek::dot_s};
486             ${Egreek::eD} = ${Egreek::eD};
487             ${Egreek::eS} = ${Egreek::eS};
488             ${Egreek::eW} = ${Egreek::eW};
489             ${Egreek::eH} = ${Egreek::eH};
490             ${Egreek::eV} = ${Egreek::eV};
491             ${Egreek::eR} = ${Egreek::eR};
492             ${Egreek::eN} = ${Egreek::eN};
493             ${Egreek::not_alnum} = ${Egreek::not_alnum};
494             ${Egreek::not_alpha} = ${Egreek::not_alpha};
495             ${Egreek::not_ascii} = ${Egreek::not_ascii};
496             ${Egreek::not_blank} = ${Egreek::not_blank};
497             ${Egreek::not_cntrl} = ${Egreek::not_cntrl};
498             ${Egreek::not_digit} = ${Egreek::not_digit};
499             ${Egreek::not_graph} = ${Egreek::not_graph};
500             ${Egreek::not_lower} = ${Egreek::not_lower};
501             ${Egreek::not_lower_i} = ${Egreek::not_lower_i};
502             ${Egreek::not_print} = ${Egreek::not_print};
503             ${Egreek::not_punct} = ${Egreek::not_punct};
504             ${Egreek::not_space} = ${Egreek::not_space};
505             ${Egreek::not_upper} = ${Egreek::not_upper};
506             ${Egreek::not_upper_i} = ${Egreek::not_upper_i};
507             ${Egreek::not_word} = ${Egreek::not_word};
508             ${Egreek::not_xdigit} = ${Egreek::not_xdigit};
509             ${Egreek::eb} = ${Egreek::eb};
510             ${Egreek::eB} = ${Egreek::eB};
511              
512             #
513             # Greek split
514             #
515             sub Egreek::split(;$$$) {
516              
517             # P.794 29.2.161. split
518             # in Chapter 29: Functions
519             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
520              
521             # P.951 split
522             # in Chapter 27: Functions
523             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
524              
525 0     0 0 0 my $pattern = $_[0];
526 0         0 my $string = $_[1];
527 0         0 my $limit = $_[2];
528              
529             # if $pattern is also omitted or is the literal space, " "
530 0 0       0 if (not defined $pattern) {
531 0         0 $pattern = ' ';
532             }
533              
534             # if $string is omitted, the function splits the $_ string
535 0 0       0 if (not defined $string) {
536 0 0       0 if (defined $_) {
537 0         0 $string = $_;
538             }
539             else {
540 0         0 $string = '';
541             }
542             }
543              
544 0         0 my @split = ();
545              
546             # when string is empty
547 0 0       0 if ($string eq '') {
    0          
548              
549             # resulting list value in list context
550 0 0       0 if (wantarray) {
551 0         0 return @split;
552             }
553              
554             # count of substrings in scalar context
555             else {
556 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
557 0         0 @_ = @split;
558 0         0 return scalar @_;
559             }
560             }
561              
562             # split's first argument is more consistently interpreted
563             #
564             # After some changes earlier in v5.17, split's behavior has been simplified:
565             # if the PATTERN argument evaluates to a string containing one space, it is
566             # treated the way that a literal string containing one space once was.
567             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
568              
569             # if $pattern is also omitted or is the literal space, " ", the function splits
570             # on whitespace, /\s+/, after skipping any leading whitespace
571             # (and so on)
572              
573             elsif ($pattern eq ' ') {
574 0 0       0 if (not defined $limit) {
575 0         0 return CORE::split(' ', $string);
576             }
577             else {
578 0         0 return CORE::split(' ', $string, $limit);
579             }
580             }
581              
582             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
583 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
584              
585             # a pattern capable of matching either the null string or something longer than the
586             # null string will split the value of $string into separate characters wherever it
587             # matches the null string between characters
588             # (and so on)
589              
590 0 0       0 if ('' =~ / \A $pattern \z /xms) {
591 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
592 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
593              
594             # P.1024 Appendix W.10 Multibyte Processing
595             # of ISBN 1-56592-224-7 CJKV Information Processing
596             # (and so on)
597              
598             # the //m modifier is assumed when you split on the pattern /^/
599             # (and so on)
600              
601             # V
602 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
603              
604             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
605             # is included in the resulting list, interspersed with the fields that are ordinarily returned
606             # (and so on)
607              
608 0         0 local $@;
609 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
610 0         0 push @split, CORE::eval('$' . $digit);
611             }
612             }
613             }
614              
615             else {
616 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
617              
618             # V
619 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
620 0         0 local $@;
621 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
622 0         0 push @split, CORE::eval('$' . $digit);
623             }
624             }
625             }
626             }
627              
628             elsif ($limit > 0) {
629 0 0       0 if ('' =~ / \A $pattern \z /xms) {
630 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
631 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
632              
633             # V
634 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
635 0         0 local $@;
636 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
637 0         0 push @split, CORE::eval('$' . $digit);
638             }
639             }
640             }
641             }
642             else {
643 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
644 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
645              
646             # V
647 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
648 0         0 local $@;
649 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
650 0         0 push @split, CORE::eval('$' . $digit);
651             }
652             }
653             }
654             }
655             }
656              
657 0 0       0 if (CORE::length($string) > 0) {
658 0         0 push @split, $string;
659             }
660              
661             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
662 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
663 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
664 0         0 pop @split;
665             }
666             }
667              
668             # resulting list value in list context
669 0 0       0 if (wantarray) {
670 0         0 return @split;
671             }
672              
673             # count of substrings in scalar context
674             else {
675 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
676 0         0 @_ = @split;
677 0         0 return scalar @_;
678             }
679             }
680              
681             #
682             # get last subexpression offsets
683             #
684             sub _last_subexpression_offsets {
685 0     0   0 my $pattern = $_[0];
686              
687             # remove comment
688 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
689              
690 0         0 my $modifier = '';
691 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
692 0         0 $modifier = $1;
693 0         0 $modifier =~ s/-[A-Za-z]*//;
694             }
695              
696             # with /x modifier
697 0         0 my @char = ();
698 0 0       0 if ($modifier =~ /x/oxms) {
699 0         0 @char = $pattern =~ /\G((?>
700             [^\\\#\[\(] |
701             \\ $q_char |
702             \# (?>[^\n]*) $ |
703             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
704             \(\? |
705             $q_char
706             ))/oxmsg;
707             }
708              
709             # without /x modifier
710             else {
711 0         0 @char = $pattern =~ /\G((?>
712             [^\\\[\(] |
713             \\ $q_char |
714             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
715             \(\? |
716             $q_char
717             ))/oxmsg;
718             }
719              
720 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
721             }
722              
723             #
724             # Greek transliteration (tr///)
725             #
726             sub Egreek::tr($$$$;$) {
727              
728 0     0 0 0 my $bind_operator = $_[1];
729 0         0 my $searchlist = $_[2];
730 0         0 my $replacementlist = $_[3];
731 0   0     0 my $modifier = $_[4] || '';
732              
733 0 0       0 if ($modifier =~ /r/oxms) {
734 0 0       0 if ($bind_operator =~ / !~ /oxms) {
735 0         0 croak "Using !~ with tr///r doesn't make sense";
736             }
737             }
738              
739 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
740 0         0 my @searchlist = _charlist_tr($searchlist);
741 0         0 my @replacementlist = _charlist_tr($replacementlist);
742              
743 0         0 my %tr = ();
744 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
745 0 0       0 if (not exists $tr{$searchlist[$i]}) {
746 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
747 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
748             }
749             elsif ($modifier =~ /d/oxms) {
750 0         0 $tr{$searchlist[$i]} = '';
751             }
752             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
753 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
754             }
755             else {
756 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
757             }
758             }
759             }
760              
761 0         0 my $tr = 0;
762 0         0 my $replaced = '';
763 0 0       0 if ($modifier =~ /c/oxms) {
764 0         0 while (defined(my $char = shift @char)) {
765 0 0       0 if (not exists $tr{$char}) {
766 0 0       0 if (defined $replacementlist[0]) {
767 0         0 $replaced .= $replacementlist[0];
768             }
769 0         0 $tr++;
770 0 0       0 if ($modifier =~ /s/oxms) {
771 0   0     0 while (@char and (not exists $tr{$char[0]})) {
772 0         0 shift @char;
773 0         0 $tr++;
774             }
775             }
776             }
777             else {
778 0         0 $replaced .= $char;
779             }
780             }
781             }
782             else {
783 0         0 while (defined(my $char = shift @char)) {
784 0 0       0 if (exists $tr{$char}) {
785 0         0 $replaced .= $tr{$char};
786 0         0 $tr++;
787 0 0       0 if ($modifier =~ /s/oxms) {
788 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
789 0         0 shift @char;
790 0         0 $tr++;
791             }
792             }
793             }
794             else {
795 0         0 $replaced .= $char;
796             }
797             }
798             }
799              
800 0 0       0 if ($modifier =~ /r/oxms) {
801 0         0 return $replaced;
802             }
803             else {
804 0         0 $_[0] = $replaced;
805 0 0       0 if ($bind_operator =~ / !~ /oxms) {
806 0         0 return not $tr;
807             }
808             else {
809 0         0 return $tr;
810             }
811             }
812             }
813              
814             #
815             # Greek chop
816             #
817             sub Egreek::chop(@) {
818              
819 0     0 0 0 my $chop;
820 0 0       0 if (@_ == 0) {
821 0         0 my @char = /\G (?>$q_char) /oxmsg;
822 0         0 $chop = pop @char;
823 0         0 $_ = join '', @char;
824             }
825             else {
826 0         0 for (@_) {
827 0         0 my @char = /\G (?>$q_char) /oxmsg;
828 0         0 $chop = pop @char;
829 0         0 $_ = join '', @char;
830             }
831             }
832 0         0 return $chop;
833             }
834              
835             #
836             # Greek index by octet
837             #
838             sub Egreek::index($$;$) {
839              
840 0     0 1 0 my($str,$substr,$position) = @_;
841 0   0     0 $position ||= 0;
842 0         0 my $pos = 0;
843              
844 0         0 while ($pos < CORE::length($str)) {
845 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
846 0 0       0 if ($pos >= $position) {
847 0         0 return $pos;
848             }
849             }
850 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
851 0         0 $pos += CORE::length($1);
852             }
853             else {
854 0         0 $pos += 1;
855             }
856             }
857 0         0 return -1;
858             }
859              
860             #
861             # Greek reverse index
862             #
863             sub Egreek::rindex($$;$) {
864              
865 0     0 0 0 my($str,$substr,$position) = @_;
866 0   0     0 $position ||= CORE::length($str) - 1;
867 0         0 my $pos = 0;
868 0         0 my $rindex = -1;
869              
870 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
871 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
872 0         0 $rindex = $pos;
873             }
874 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
875 0         0 $pos += CORE::length($1);
876             }
877             else {
878 0         0 $pos += 1;
879             }
880             }
881 0         0 return $rindex;
882             }
883              
884             #
885             # Greek lower case first with parameter
886             #
887             sub Egreek::lcfirst(@) {
888 0 0   0 0 0 if (@_) {
889 0         0 my $s = shift @_;
890 0 0 0     0 if (@_ and wantarray) {
891 0         0 return Egreek::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
892             }
893             else {
894 0         0 return Egreek::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
895             }
896             }
897             else {
898 0         0 return Egreek::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
899             }
900             }
901              
902             #
903             # Greek lower case first without parameter
904             #
905             sub Egreek::lcfirst_() {
906 0     0 0 0 return Egreek::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
907             }
908              
909             #
910             # Greek lower case with parameter
911             #
912             sub Egreek::lc(@) {
913 0 0   0 0 0 if (@_) {
914 0         0 my $s = shift @_;
915 0 0 0     0 if (@_ and wantarray) {
916 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
917             }
918             else {
919 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
920             }
921             }
922             else {
923 0         0 return Egreek::lc_();
924             }
925             }
926              
927             #
928             # Greek lower case without parameter
929             #
930             sub Egreek::lc_() {
931 0     0 0 0 my $s = $_;
932 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
933             }
934              
935             #
936             # Greek upper case first with parameter
937             #
938             sub Egreek::ucfirst(@) {
939 0 0   0 0 0 if (@_) {
940 0         0 my $s = shift @_;
941 0 0 0     0 if (@_ and wantarray) {
942 0         0 return Egreek::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
943             }
944             else {
945 0         0 return Egreek::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
946             }
947             }
948             else {
949 0         0 return Egreek::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
950             }
951             }
952              
953             #
954             # Greek upper case first without parameter
955             #
956             sub Egreek::ucfirst_() {
957 0     0 0 0 return Egreek::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
958             }
959              
960             #
961             # Greek upper case with parameter
962             #
963             sub Egreek::uc(@) {
964 0 50   174 0 0 if (@_) {
965 174         328 my $s = shift @_;
966 174 50 33     308 if (@_ and wantarray) {
967 174 0       327 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
968             }
969             else {
970 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         554  
971             }
972             }
973             else {
974 174         647 return Egreek::uc_();
975             }
976             }
977              
978             #
979             # Greek upper case without parameter
980             #
981             sub Egreek::uc_() {
982 0     0 0 0 my $s = $_;
983 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
984             }
985              
986             #
987             # Greek fold case with parameter
988             #
989             sub Egreek::fc(@) {
990 0 50   197 0 0 if (@_) {
991 197         285 my $s = shift @_;
992 197 50 33     225 if (@_ and wantarray) {
993 197 0       326 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
994             }
995             else {
996 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         745  
997             }
998             }
999             else {
1000 197         1347 return Egreek::fc_();
1001             }
1002             }
1003              
1004             #
1005             # Greek fold case without parameter
1006             #
1007             sub Egreek::fc_() {
1008 0     0 0 0 my $s = $_;
1009 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1010             }
1011              
1012             #
1013             # Greek regexp capture
1014             #
1015             {
1016             sub Egreek::capture {
1017 0     0 1 0 return $_[0];
1018             }
1019             }
1020              
1021             #
1022             # Greek regexp ignore case modifier
1023             #
1024             sub Egreek::ignorecase {
1025              
1026 0     0 0 0 my @string = @_;
1027 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1028              
1029             # ignore case of $scalar or @array
1030 0         0 for my $string (@string) {
1031              
1032             # split regexp
1033 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1034              
1035             # unescape character
1036 0         0 for (my $i=0; $i <= $#char; $i++) {
1037 0 0       0 next if not defined $char[$i];
1038              
1039             # open character class [...]
1040 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1041 0         0 my $left = $i;
1042              
1043             # [] make die "unmatched [] in regexp ...\n"
1044              
1045 0 0       0 if ($char[$i+1] eq ']') {
1046 0         0 $i++;
1047             }
1048              
1049 0         0 while (1) {
1050 0 0       0 if (++$i > $#char) {
1051 0         0 croak "Unmatched [] in regexp";
1052             }
1053 0 0       0 if ($char[$i] eq ']') {
1054 0         0 my $right = $i;
1055 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1056              
1057             # escape character
1058 0         0 for my $char (@charlist) {
1059 0 0       0 if (0) {
1060             }
1061              
1062 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1063 0         0 $char = '\\' . $char;
1064             }
1065             }
1066              
1067             # [...]
1068 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1069              
1070 0         0 $i = $left;
1071 0         0 last;
1072             }
1073             }
1074             }
1075              
1076             # open character class [^...]
1077             elsif ($char[$i] eq '[^') {
1078 0         0 my $left = $i;
1079              
1080             # [^] make die "unmatched [] in regexp ...\n"
1081              
1082 0 0       0 if ($char[$i+1] eq ']') {
1083 0         0 $i++;
1084             }
1085              
1086 0         0 while (1) {
1087 0 0       0 if (++$i > $#char) {
1088 0         0 croak "Unmatched [] in regexp";
1089             }
1090 0 0       0 if ($char[$i] eq ']') {
1091 0         0 my $right = $i;
1092 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1093              
1094             # escape character
1095 0         0 for my $char (@charlist) {
1096 0 0       0 if (0) {
1097             }
1098              
1099 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1100 0         0 $char = '\\' . $char;
1101             }
1102             }
1103              
1104             # [^...]
1105 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1106              
1107 0         0 $i = $left;
1108 0         0 last;
1109             }
1110             }
1111             }
1112              
1113             # rewrite classic character class or escape character
1114             elsif (my $char = classic_character_class($char[$i])) {
1115 0         0 $char[$i] = $char;
1116             }
1117              
1118             # with /i modifier
1119             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1120 0         0 my $uc = Egreek::uc($char[$i]);
1121 0         0 my $fc = Egreek::fc($char[$i]);
1122 0 0       0 if ($uc ne $fc) {
1123 0 0       0 if (CORE::length($fc) == 1) {
1124 0         0 $char[$i] = '[' . $uc . $fc . ']';
1125             }
1126             else {
1127 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1128             }
1129             }
1130             }
1131             }
1132              
1133             # characterize
1134 0         0 for (my $i=0; $i <= $#char; $i++) {
1135 0 0       0 next if not defined $char[$i];
1136              
1137 0 0       0 if (0) {
1138             }
1139              
1140             # quote character before ? + * {
1141 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1142 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1143 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1144             }
1145             }
1146             }
1147              
1148 0         0 $string = join '', @char;
1149             }
1150              
1151             # make regexp string
1152 0         0 return @string;
1153             }
1154              
1155             #
1156             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1157             #
1158             sub Egreek::classic_character_class {
1159 0     1867 0 0 my($char) = @_;
1160              
1161             return {
1162             '\D' => '${Egreek::eD}',
1163             '\S' => '${Egreek::eS}',
1164             '\W' => '${Egreek::eW}',
1165             '\d' => '[0-9]',
1166              
1167             # Before Perl 5.6, \s only matched the five whitespace characters
1168             # tab, newline, form-feed, carriage return, and the space character
1169             # itself, which, taken together, is the character class [\t\n\f\r ].
1170              
1171             # Vertical tabs are now whitespace
1172             # \s in a regex now matches a vertical tab in all circumstances.
1173             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1174             # \t \n \v \f \r space
1175             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1176             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1177             '\s' => '\s',
1178              
1179             '\w' => '[0-9A-Z_a-z]',
1180             '\C' => '[\x00-\xFF]',
1181             '\X' => 'X',
1182              
1183             # \h \v \H \V
1184              
1185             # P.114 Character Class Shortcuts
1186             # in Chapter 7: In the World of Regular Expressions
1187             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1188              
1189             # P.357 13.2.3 Whitespace
1190             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1191             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1192             #
1193             # 0x00009 CHARACTER TABULATION h s
1194             # 0x0000a LINE FEED (LF) vs
1195             # 0x0000b LINE TABULATION v
1196             # 0x0000c FORM FEED (FF) vs
1197             # 0x0000d CARRIAGE RETURN (CR) vs
1198             # 0x00020 SPACE h s
1199              
1200             # P.196 Table 5-9. Alphanumeric regex metasymbols
1201             # in Chapter 5. Pattern Matching
1202             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1203              
1204             # (and so on)
1205              
1206             '\H' => '${Egreek::eH}',
1207             '\V' => '${Egreek::eV}',
1208             '\h' => '[\x09\x20]',
1209             '\v' => '[\x0A\x0B\x0C\x0D]',
1210             '\R' => '${Egreek::eR}',
1211              
1212             # \N
1213             #
1214             # http://perldoc.perl.org/perlre.html
1215             # Character Classes and other Special Escapes
1216             # Any character but \n (experimental). Not affected by /s modifier
1217              
1218             '\N' => '${Egreek::eN}',
1219              
1220             # \b \B
1221              
1222             # P.180 Boundaries: The \b and \B Assertions
1223             # in Chapter 5: Pattern Matching
1224             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1225              
1226             # P.219 Boundaries: The \b and \B Assertions
1227             # in Chapter 5: Pattern Matching
1228             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1229              
1230             # \b really means (?:(?<=\w)(?!\w)|(?
1231             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1232             '\b' => '${Egreek::eb}',
1233              
1234             # \B really means (?:(?<=\w)(?=\w)|(?
1235             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1236             '\B' => '${Egreek::eB}',
1237              
1238 1867   100     3869 }->{$char} || '';
1239             }
1240              
1241             #
1242             # prepare Greek characters per length
1243             #
1244              
1245             # 1 octet characters
1246             my @chars1 = ();
1247             sub chars1 {
1248 1867 0   0 0 71691 if (@chars1) {
1249 0         0 return @chars1;
1250             }
1251 0 0       0 if (exists $range_tr{1}) {
1252 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1253 0         0 while (my @range = splice(@ranges,0,1)) {
1254 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1255 0         0 push @chars1, pack 'C', $oct0;
1256             }
1257             }
1258             }
1259 0         0 return @chars1;
1260             }
1261              
1262             # 2 octets characters
1263             my @chars2 = ();
1264             sub chars2 {
1265 0 0   0 0 0 if (@chars2) {
1266 0         0 return @chars2;
1267             }
1268 0 0       0 if (exists $range_tr{2}) {
1269 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1270 0         0 while (my @range = splice(@ranges,0,2)) {
1271 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1272 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1273 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1274             }
1275             }
1276             }
1277             }
1278 0         0 return @chars2;
1279             }
1280              
1281             # 3 octets characters
1282             my @chars3 = ();
1283             sub chars3 {
1284 0 0   0 0 0 if (@chars3) {
1285 0         0 return @chars3;
1286             }
1287 0 0       0 if (exists $range_tr{3}) {
1288 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1289 0         0 while (my @range = splice(@ranges,0,3)) {
1290 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1291 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1292 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1293 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1294             }
1295             }
1296             }
1297             }
1298             }
1299 0         0 return @chars3;
1300             }
1301              
1302             # 4 octets characters
1303             my @chars4 = ();
1304             sub chars4 {
1305 0 0   0 0 0 if (@chars4) {
1306 0         0 return @chars4;
1307             }
1308 0 0       0 if (exists $range_tr{4}) {
1309 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1310 0         0 while (my @range = splice(@ranges,0,4)) {
1311 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1312 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1313 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1314 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1315 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1316             }
1317             }
1318             }
1319             }
1320             }
1321             }
1322 0         0 return @chars4;
1323             }
1324              
1325             #
1326             # Greek open character list for tr
1327             #
1328             sub _charlist_tr {
1329              
1330 0     0   0 local $_ = shift @_;
1331              
1332             # unescape character
1333 0         0 my @char = ();
1334 0         0 while (not /\G \z/oxmsgc) {
1335 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1336 0         0 push @char, '\-';
1337             }
1338             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1339 0         0 push @char, CORE::chr(oct $1);
1340             }
1341             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1342 0         0 push @char, CORE::chr(hex $1);
1343             }
1344             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1345 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1346             }
1347             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1348             push @char, {
1349             '\0' => "\0",
1350             '\n' => "\n",
1351             '\r' => "\r",
1352             '\t' => "\t",
1353             '\f' => "\f",
1354             '\b' => "\x08", # \b means backspace in character class
1355             '\a' => "\a",
1356             '\e' => "\e",
1357 0         0 }->{$1};
1358             }
1359             elsif (/\G \\ ($q_char) /oxmsgc) {
1360 0         0 push @char, $1;
1361             }
1362             elsif (/\G ($q_char) /oxmsgc) {
1363 0         0 push @char, $1;
1364             }
1365             }
1366              
1367             # join separated multiple-octet
1368 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1369              
1370             # unescape '-'
1371 0         0 my @i = ();
1372 0         0 for my $i (0 .. $#char) {
1373 0 0       0 if ($char[$i] eq '\-') {
    0          
1374 0         0 $char[$i] = '-';
1375             }
1376             elsif ($char[$i] eq '-') {
1377 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1378 0         0 push @i, $i;
1379             }
1380             }
1381             }
1382              
1383             # open character list (reverse for splice)
1384 0         0 for my $i (CORE::reverse @i) {
1385 0         0 my @range = ();
1386              
1387             # range error
1388 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1389 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1390             }
1391              
1392             # range of multiple-octet code
1393 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1394 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1395 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1396             }
1397             elsif (CORE::length($char[$i+1]) == 2) {
1398 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1399 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1400             }
1401             elsif (CORE::length($char[$i+1]) == 3) {
1402 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1403 0         0 push @range, chars2();
1404 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1405             }
1406             elsif (CORE::length($char[$i+1]) == 4) {
1407 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1408 0         0 push @range, chars2();
1409 0         0 push @range, chars3();
1410 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1411             }
1412             else {
1413 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1414             }
1415             }
1416             elsif (CORE::length($char[$i-1]) == 2) {
1417 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1418 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1419             }
1420             elsif (CORE::length($char[$i+1]) == 3) {
1421 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1422 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1423             }
1424             elsif (CORE::length($char[$i+1]) == 4) {
1425 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1426 0         0 push @range, chars3();
1427 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1428             }
1429             else {
1430 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1431             }
1432             }
1433             elsif (CORE::length($char[$i-1]) == 3) {
1434 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1435 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1436             }
1437             elsif (CORE::length($char[$i+1]) == 4) {
1438 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1439 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1440             }
1441             else {
1442 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1443             }
1444             }
1445             elsif (CORE::length($char[$i-1]) == 4) {
1446 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1447 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1448             }
1449             else {
1450 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1451             }
1452             }
1453             else {
1454 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1455             }
1456              
1457 0         0 splice @char, $i-1, 3, @range;
1458             }
1459              
1460 0         0 return @char;
1461             }
1462              
1463             #
1464             # Greek open character class
1465             #
1466             sub _cc {
1467 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1468 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1469             }
1470             elsif (scalar(@_) == 1) {
1471 0         0 return sprintf('\x%02X',$_[0]);
1472             }
1473             elsif (scalar(@_) == 2) {
1474 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1475 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1476             }
1477             elsif ($_[0] == $_[1]) {
1478 0         0 return sprintf('\x%02X',$_[0]);
1479             }
1480             elsif (($_[0]+1) == $_[1]) {
1481 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1482             }
1483             else {
1484 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1485             }
1486             }
1487             else {
1488 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1489             }
1490             }
1491              
1492             #
1493             # Greek octet range
1494             #
1495             sub _octets {
1496 0     182   0 my $length = shift @_;
1497              
1498 182 50       415 if ($length == 1) {
1499 182         384 my($a1) = unpack 'C', $_[0];
1500 182         688 my($z1) = unpack 'C', $_[1];
1501              
1502 182 50       354 if ($a1 > $z1) {
1503 182         393 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1504             }
1505              
1506 0 50       0 if ($a1 == $z1) {
    50          
1507 182         423 return sprintf('\x%02X',$a1);
1508             }
1509             elsif (($a1+1) == $z1) {
1510 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1511             }
1512             else {
1513 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1514             }
1515             }
1516             else {
1517 182         1277 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1518             }
1519             }
1520              
1521             #
1522             # Greek range regexp
1523             #
1524             sub _range_regexp {
1525 0     182   0 my($length,$first,$last) = @_;
1526              
1527 182         415 my @range_regexp = ();
1528 182 50       245 if (not exists $range_tr{$length}) {
1529 182         467 return @range_regexp;
1530             }
1531              
1532 0         0 my @ranges = @{ $range_tr{$length} };
  182         266  
1533 182         529 while (my @range = splice(@ranges,0,$length)) {
1534 182         661 my $min = '';
1535 182         284 my $max = '';
1536 182         224 for (my $i=0; $i < $length; $i++) {
1537 182         493 $min .= pack 'C', $range[$i][0];
1538 182         694 $max .= pack 'C', $range[$i][-1];
1539             }
1540              
1541             # min___max
1542             # FIRST_____________LAST
1543             # (nothing)
1544              
1545 182 50 33     461 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1546             }
1547              
1548             # **********
1549             # min_________max
1550             # FIRST_____________LAST
1551             # **********
1552              
1553             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1554 182         2055 push @range_regexp, _octets($length,$first,$max,$min,$max);
1555             }
1556              
1557             # **********************
1558             # min________________max
1559             # FIRST_____________LAST
1560             # **********************
1561              
1562             elsif (($min eq $first) and ($max eq $last)) {
1563 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1564             }
1565              
1566             # *********
1567             # min___max
1568             # FIRST_____________LAST
1569             # *********
1570              
1571             elsif (($first le $min) and ($max le $last)) {
1572 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1573             }
1574              
1575             # **********************
1576             # min__________________________max
1577             # FIRST_____________LAST
1578             # **********************
1579              
1580             elsif (($min le $first) and ($last le $max)) {
1581 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1582             }
1583              
1584             # *********
1585             # min________max
1586             # FIRST_____________LAST
1587             # *********
1588              
1589             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1590 182         490 push @range_regexp, _octets($length,$min,$last,$min,$max);
1591             }
1592              
1593             # min___max
1594             # FIRST_____________LAST
1595             # (nothing)
1596              
1597             elsif ($last lt $min) {
1598             }
1599              
1600             else {
1601 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1602             }
1603             }
1604              
1605 0         0 return @range_regexp;
1606             }
1607              
1608             #
1609             # Greek open character list for qr and not qr
1610             #
1611             sub _charlist {
1612              
1613 182     358   397 my $modifier = pop @_;
1614 358         592 my @char = @_;
1615              
1616 358 100       785 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1617              
1618             # unescape character
1619 358         868 for (my $i=0; $i <= $#char; $i++) {
1620              
1621             # escape - to ...
1622 358 100 100     1416 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1623 1125 100 100     10465 if ((0 < $i) and ($i < $#char)) {
1624 206         845 $char[$i] = '...';
1625             }
1626             }
1627              
1628             # octal escape sequence
1629             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1630 182         369 $char[$i] = octchr($1);
1631             }
1632              
1633             # hexadecimal escape sequence
1634             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1635 0         0 $char[$i] = hexchr($1);
1636             }
1637              
1638             # \b{...} --> b\{...}
1639             # \B{...} --> B\{...}
1640             # \N{CHARNAME} --> N\{CHARNAME}
1641             # \p{PROPERTY} --> p\{PROPERTY}
1642             # \P{PROPERTY} --> P\{PROPERTY}
1643             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1644 0         0 $char[$i] = $1 . '\\' . $2;
1645             }
1646              
1647             # \p, \P, \X --> p, P, X
1648             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1649 0         0 $char[$i] = $1;
1650             }
1651              
1652             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1653 0         0 $char[$i] = CORE::chr oct $1;
1654             }
1655             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1656 0         0 $char[$i] = CORE::chr hex $1;
1657             }
1658             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1659 22         104 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1660             }
1661             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1662             $char[$i] = {
1663             '\0' => "\0",
1664             '\n' => "\n",
1665             '\r' => "\r",
1666             '\t' => "\t",
1667             '\f' => "\f",
1668             '\b' => "\x08", # \b means backspace in character class
1669             '\a' => "\a",
1670             '\e' => "\e",
1671             '\d' => '[0-9]',
1672              
1673             # Vertical tabs are now whitespace
1674             # \s in a regex now matches a vertical tab in all circumstances.
1675             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1676             # \t \n \v \f \r space
1677             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1678             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1679             '\s' => '\s',
1680              
1681             '\w' => '[0-9A-Z_a-z]',
1682             '\D' => '${Egreek::eD}',
1683             '\S' => '${Egreek::eS}',
1684             '\W' => '${Egreek::eW}',
1685              
1686             '\H' => '${Egreek::eH}',
1687             '\V' => '${Egreek::eV}',
1688             '\h' => '[\x09\x20]',
1689             '\v' => '[\x0A\x0B\x0C\x0D]',
1690             '\R' => '${Egreek::eR}',
1691              
1692 0         0 }->{$1};
1693             }
1694              
1695             # POSIX-style character classes
1696             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1697             $char[$i] = {
1698              
1699             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1700             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1701             '[:^lower:]' => '${Egreek::not_lower_i}',
1702             '[:^upper:]' => '${Egreek::not_upper_i}',
1703              
1704 25         420 }->{$1};
1705             }
1706             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1707             $char[$i] = {
1708              
1709             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1710             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1711             '[:ascii:]' => '[\x00-\x7F]',
1712             '[:blank:]' => '[\x09\x20]',
1713             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1714             '[:digit:]' => '[\x30-\x39]',
1715             '[:graph:]' => '[\x21-\x7F]',
1716             '[:lower:]' => '[\x61-\x7A]',
1717             '[:print:]' => '[\x20-\x7F]',
1718             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1719              
1720             # P.174 POSIX-Style Character Classes
1721             # in Chapter 5: Pattern Matching
1722             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1723              
1724             # P.311 11.2.4 Character Classes and other Special Escapes
1725             # in Chapter 11: perlre: Perl regular expressions
1726             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1727              
1728             # P.210 POSIX-Style Character Classes
1729             # in Chapter 5: Pattern Matching
1730             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1731              
1732             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1733              
1734             '[:upper:]' => '[\x41-\x5A]',
1735             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1736             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1737             '[:^alnum:]' => '${Egreek::not_alnum}',
1738             '[:^alpha:]' => '${Egreek::not_alpha}',
1739             '[:^ascii:]' => '${Egreek::not_ascii}',
1740             '[:^blank:]' => '${Egreek::not_blank}',
1741             '[:^cntrl:]' => '${Egreek::not_cntrl}',
1742             '[:^digit:]' => '${Egreek::not_digit}',
1743             '[:^graph:]' => '${Egreek::not_graph}',
1744             '[:^lower:]' => '${Egreek::not_lower}',
1745             '[:^print:]' => '${Egreek::not_print}',
1746             '[:^punct:]' => '${Egreek::not_punct}',
1747             '[:^space:]' => '${Egreek::not_space}',
1748             '[:^upper:]' => '${Egreek::not_upper}',
1749             '[:^word:]' => '${Egreek::not_word}',
1750             '[:^xdigit:]' => '${Egreek::not_xdigit}',
1751              
1752 8         78 }->{$1};
1753             }
1754             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1755 70         1413 $char[$i] = $1;
1756             }
1757             }
1758              
1759             # open character list
1760 7         31 my @singleoctet = ();
1761 358         827 my @multipleoctet = ();
1762 358         506 for (my $i=0; $i <= $#char; ) {
1763              
1764             # escaped -
1765 358 100 100     941 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1766 943         4388 $i += 1;
1767 182         244 next;
1768             }
1769              
1770             # make range regexp
1771             elsif ($char[$i] eq '...') {
1772              
1773             # range error
1774 182 50       328 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1775 182         1160 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1776             }
1777             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1778 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1779 182         567 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1780             }
1781             }
1782              
1783             # make range regexp per length
1784 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1785 182         587 my @regexp = ();
1786              
1787             # is first and last
1788 182 50 33     303 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1789 182         727 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1790             }
1791              
1792             # is first
1793             elsif ($length == CORE::length($char[$i-1])) {
1794 182         513 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1795             }
1796              
1797             # is inside in first and last
1798             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1799 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1800             }
1801              
1802             # is last
1803             elsif ($length == CORE::length($char[$i+1])) {
1804 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1805             }
1806              
1807             else {
1808 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1809             }
1810              
1811 0 50       0 if ($length == 1) {
1812 182         417 push @singleoctet, @regexp;
1813             }
1814             else {
1815 182         431 push @multipleoctet, @regexp;
1816             }
1817             }
1818              
1819 0         0 $i += 2;
1820             }
1821              
1822             # with /i modifier
1823             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1824 182 100       367 if ($modifier =~ /i/oxms) {
1825 493         705 my $uc = Egreek::uc($char[$i]);
1826 24         184 my $fc = Egreek::fc($char[$i]);
1827 24 100       47 if ($uc ne $fc) {
1828 24 50       47 if (CORE::length($fc) == 1) {
1829 12         26 push @singleoctet, $uc, $fc;
1830             }
1831             else {
1832 12         33 push @singleoctet, $uc;
1833 0         0 push @multipleoctet, $fc;
1834             }
1835             }
1836             else {
1837 0         0 push @singleoctet, $char[$i];
1838             }
1839             }
1840             else {
1841 12         30 push @singleoctet, $char[$i];
1842             }
1843 469         873 $i += 1;
1844             }
1845              
1846             # single character of single octet code
1847             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1848 493         991 push @singleoctet, "\t", "\x20";
1849 0         0 $i += 1;
1850             }
1851             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1852 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1853 0         0 $i += 1;
1854             }
1855             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1856 0         0 push @singleoctet, $char[$i];
1857 2         5 $i += 1;
1858             }
1859              
1860             # single character of multiple-octet code
1861             else {
1862 2         4 push @multipleoctet, $char[$i];
1863 84         224 $i += 1;
1864             }
1865             }
1866              
1867             # quote metachar
1868 84         171 for (@singleoctet) {
1869 358 50       685 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1870 689         3666 $_ = '-';
1871             }
1872             elsif (/\A \n \z/oxms) {
1873 0         0 $_ = '\n';
1874             }
1875             elsif (/\A \r \z/oxms) {
1876 8         24 $_ = '\r';
1877             }
1878             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1879 8         22 $_ = sprintf('\x%02X', CORE::ord $1);
1880             }
1881             elsif (/\A [\x00-\xFF] \z/oxms) {
1882 60         197 $_ = quotemeta $_;
1883             }
1884             }
1885              
1886             # return character list
1887 429         999 return \@singleoctet, \@multipleoctet;
1888             }
1889              
1890             #
1891             # Greek octal escape sequence
1892             #
1893             sub octchr {
1894 358     5 0 1530 my($octdigit) = @_;
1895              
1896 5         13 my @binary = ();
1897 5         8 for my $octal (split(//,$octdigit)) {
1898             push @binary, {
1899             '0' => '000',
1900             '1' => '001',
1901             '2' => '010',
1902             '3' => '011',
1903             '4' => '100',
1904             '5' => '101',
1905             '6' => '110',
1906             '7' => '111',
1907 5         20 }->{$octal};
1908             }
1909 50         169 my $binary = join '', @binary;
1910              
1911             my $octchr = {
1912             # 1234567
1913             1 => pack('B*', "0000000$binary"),
1914             2 => pack('B*', "000000$binary"),
1915             3 => pack('B*', "00000$binary"),
1916             4 => pack('B*', "0000$binary"),
1917             5 => pack('B*', "000$binary"),
1918             6 => pack('B*', "00$binary"),
1919             7 => pack('B*', "0$binary"),
1920             0 => pack('B*', "$binary"),
1921              
1922 5         14 }->{CORE::length($binary) % 8};
1923              
1924 5         57 return $octchr;
1925             }
1926              
1927             #
1928             # Greek hexadecimal escape sequence
1929             #
1930             sub hexchr {
1931 5     5 0 18 my($hexdigit) = @_;
1932              
1933             my $hexchr = {
1934             1 => pack('H*', "0$hexdigit"),
1935             0 => pack('H*', "$hexdigit"),
1936              
1937 5         16 }->{CORE::length($_[0]) % 2};
1938              
1939 5         39 return $hexchr;
1940             }
1941              
1942             #
1943             # Greek open character list for qr
1944             #
1945             sub charlist_qr {
1946              
1947 5     314 0 18 my $modifier = pop @_;
1948 314         613 my @char = @_;
1949              
1950 314         800 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1951 314         1002 my @singleoctet = @$singleoctet;
1952 314         907 my @multipleoctet = @$multipleoctet;
1953              
1954             # return character list
1955 314 100       562 if (scalar(@singleoctet) >= 1) {
1956              
1957             # with /i modifier
1958 314 100       818 if ($modifier =~ m/i/oxms) {
1959 236         623 my %singleoctet_ignorecase = ();
1960 22         37 for (@singleoctet) {
1961 22   100     38 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1962 46         465 for my $ord (hex($1) .. hex($2)) {
1963 46         141 my $char = CORE::chr($ord);
1964 66         94 my $uc = Egreek::uc($char);
1965 66         106 my $fc = Egreek::fc($char);
1966 66 100       102 if ($uc eq $fc) {
1967 66         112 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1968             }
1969             else {
1970 12 50       81 if (CORE::length($fc) == 1) {
1971 54         90 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1972 54         121 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1973             }
1974             else {
1975 54         187 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1976 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1977             }
1978             }
1979             }
1980             }
1981 0 50       0 if ($_ ne '') {
1982 46         102 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1983             }
1984             }
1985 0         0 my $i = 0;
1986 22         33 my @singleoctet_ignorecase = ();
1987 22         41 for my $ord (0 .. 255) {
1988 22 100       39 if (exists $singleoctet_ignorecase{$ord}) {
1989 5632         6311 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         92  
1990             }
1991             else {
1992 96         201 $i++;
1993             }
1994             }
1995 5536         5462 @singleoctet = ();
1996 22         37 for my $range (@singleoctet_ignorecase) {
1997 22 100       64 if (ref $range) {
1998 3648 100       5887 if (scalar(@{$range}) == 1) {
  56 50       57  
1999 56         84 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         53  
2000             }
2001 36         112 elsif (scalar(@{$range}) == 2) {
2002 20         24 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2003             }
2004             else {
2005 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         25  
  20         27  
2006             }
2007             }
2008             }
2009             }
2010              
2011 20         80 my $not_anchor = '';
2012              
2013 236         392 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2014             }
2015 236 100       660 if (scalar(@multipleoctet) >= 2) {
2016 314         1198 return '(?:' . join('|', @multipleoctet) . ')';
2017             }
2018             else {
2019 6         26 return $multipleoctet[0];
2020             }
2021             }
2022              
2023             #
2024             # Greek open character list for not qr
2025             #
2026             sub charlist_not_qr {
2027              
2028 308     44 0 1888 my $modifier = pop @_;
2029 44         93 my @char = @_;
2030              
2031 44         98 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2032 44         116 my @singleoctet = @$singleoctet;
2033 44         103 my @multipleoctet = @$multipleoctet;
2034              
2035             # with /i modifier
2036 44 100       62 if ($modifier =~ m/i/oxms) {
2037 44         116 my %singleoctet_ignorecase = ();
2038 10         13 for (@singleoctet) {
2039 10   66     14 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2040 10         44 for my $ord (hex($1) .. hex($2)) {
2041 10         34 my $char = CORE::chr($ord);
2042 30         40 my $uc = Egreek::uc($char);
2043 30         50 my $fc = Egreek::fc($char);
2044 30 50       49 if ($uc eq $fc) {
2045 30         48 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2046             }
2047             else {
2048 0 50       0 if (CORE::length($fc) == 1) {
2049 30         48 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2050 30         65 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2051             }
2052             else {
2053 30         95 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2054 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2055             }
2056             }
2057             }
2058             }
2059 0 50       0 if ($_ ne '') {
2060 10         29 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2061             }
2062             }
2063 0         0 my $i = 0;
2064 10         14 my @singleoctet_ignorecase = ();
2065 10         13 for my $ord (0 .. 255) {
2066 10 100       15 if (exists $singleoctet_ignorecase{$ord}) {
2067 2560         2812 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         60  
2068             }
2069             else {
2070 60         96 $i++;
2071             }
2072             }
2073 2500         2459 @singleoctet = ();
2074 10         14 for my $range (@singleoctet_ignorecase) {
2075 10 100       22 if (ref $range) {
2076 960 50       1426 if (scalar(@{$range}) == 1) {
  20 50       21  
2077 20         30 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2078             }
2079 0         0 elsif (scalar(@{$range}) == 2) {
2080 20         25 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2081             }
2082             else {
2083 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         24  
  20         26  
2084             }
2085             }
2086             }
2087             }
2088              
2089             # return character list
2090 20 50       72 if (scalar(@multipleoctet) >= 1) {
2091 44 0       119 if (scalar(@singleoctet) >= 1) {
2092              
2093             # any character other than multiple-octet and single octet character class
2094 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2095             }
2096             else {
2097              
2098             # any character other than multiple-octet character class
2099 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2100             }
2101             }
2102             else {
2103 0 50       0 if (scalar(@singleoctet) >= 1) {
2104              
2105             # any character other than single octet character class
2106 44         91 return '(?:[^' . join('', @singleoctet) . '])';
2107             }
2108             else {
2109              
2110             # any character
2111 44         247 return "(?:$your_char)";
2112             }
2113             }
2114             }
2115              
2116             #
2117             # open file in read mode
2118             #
2119             sub _open_r {
2120 0     408   0 my(undef,$file) = @_;
2121 204     204   2308 use Fcntl qw(O_RDONLY);
  204         496  
  204         34096  
2122 408         1660 return CORE::sysopen($_[0], $file, &O_RDONLY);
2123             }
2124              
2125             #
2126             # open file in append mode
2127             #
2128             sub _open_a {
2129 408     204   19607 my(undef,$file) = @_;
2130 204     204   1715 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         624  
  204         814177  
2131 204         642 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2132             }
2133              
2134             #
2135             # safe system
2136             #
2137             sub _systemx {
2138              
2139             # P.707 29.2.33. exec
2140             # in Chapter 29: Functions
2141             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2142             #
2143             # Be aware that in older releases of Perl, exec (and system) did not flush
2144             # your output buffer, so you needed to enable command buffering by setting $|
2145             # on one or more filehandles to avoid lost output in the case of exec, or
2146             # misordererd output in the case of system. This situation was largely remedied
2147             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2148              
2149             # P.855 exec
2150             # in Chapter 27: Functions
2151             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2152             #
2153             # In very old release of Perl (before v5.6), 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 with exec or misordered
2156             # output with system.
2157              
2158 204     204   40356 $| = 1;
2159              
2160             # P.565 23.1.2. Cleaning Up Your Environment
2161             # in Chapter 23: Security
2162             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2163              
2164             # P.656 Cleaning Up Your Environment
2165             # in Chapter 20: Security
2166             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2167              
2168             # local $ENV{'PATH'} = '.';
2169 204         13792 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2170              
2171             # P.707 29.2.33. exec
2172             # in Chapter 29: Functions
2173             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2174             #
2175             # As we mentioned earlier, exec treats a discrete list of arguments as an
2176             # indication that it should bypass shell processing. However, there is one
2177             # place where you might still get tripped up. The exec call (and system, too)
2178             # will not distinguish between a single scalar argument and an array containing
2179             # only one element.
2180             #
2181             # @args = ("echo surprise"); # just one element in list
2182             # exec @args # still subject to shell escapes
2183             # or die "exec: $!"; # because @args == 1
2184             #
2185             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2186             # first argument as the pathname, which forces the rest of the arguments to be
2187             # interpreted as a list, even if there is only one of them:
2188             #
2189             # exec { $args[0] } @args # safe even with one-argument list
2190             # or die "can't exec @args: $!";
2191              
2192             # P.855 exec
2193             # in Chapter 27: Functions
2194             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2195             #
2196             # As we mentioned earlier, exec treats a discrete list of arguments as a
2197             # directive to bypass shell processing. However, there is one place where
2198             # you might still get tripped up. The exec call (and system, too) cannot
2199             # distinguish between a single scalar argument and an array containing
2200             # only one element.
2201             #
2202             # @args = ("echo surprise"); # just one element in list
2203             # exec @args # still subject to shell escapes
2204             # || die "exec: $!"; # because @args == 1
2205             #
2206             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2207             # argument as the pathname, which forces the rest of the arguments to be
2208             # interpreted as a list, even if there is only one of them:
2209             #
2210             # exec { $args[0] } @args # safe even with one-argument list
2211             # || die "can't exec @args: $!";
2212              
2213 204         17204 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         423  
2214             }
2215              
2216             #
2217             # Greek order to character (with parameter)
2218             #
2219             sub Egreek::chr(;$) {
2220              
2221 204 0   0 0 22067657 my $c = @_ ? $_[0] : $_;
2222              
2223 0 0       0 if ($c == 0x00) {
2224 0         0 return "\x00";
2225             }
2226             else {
2227 0         0 my @chr = ();
2228 0         0 while ($c > 0) {
2229 0         0 unshift @chr, ($c % 0x100);
2230 0         0 $c = int($c / 0x100);
2231             }
2232 0         0 return pack 'C*', @chr;
2233             }
2234             }
2235              
2236             #
2237             # Greek order to character (without parameter)
2238             #
2239             sub Egreek::chr_() {
2240              
2241 0     0 0 0 my $c = $_;
2242              
2243 0 0       0 if ($c == 0x00) {
2244 0         0 return "\x00";
2245             }
2246             else {
2247 0         0 my @chr = ();
2248 0         0 while ($c > 0) {
2249 0         0 unshift @chr, ($c % 0x100);
2250 0         0 $c = int($c / 0x100);
2251             }
2252 0         0 return pack 'C*', @chr;
2253             }
2254             }
2255              
2256             #
2257             # Greek path globbing (with parameter)
2258             #
2259             sub Egreek::glob($) {
2260              
2261 0 0   0 0 0 if (wantarray) {
2262 0         0 my @glob = _DOS_like_glob(@_);
2263 0         0 for my $glob (@glob) {
2264 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2265             }
2266 0         0 return @glob;
2267             }
2268             else {
2269 0         0 my $glob = _DOS_like_glob(@_);
2270 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2271 0         0 return $glob;
2272             }
2273             }
2274              
2275             #
2276             # Greek path globbing (without parameter)
2277             #
2278             sub Egreek::glob_() {
2279              
2280 0 0   0 0 0 if (wantarray) {
2281 0         0 my @glob = _DOS_like_glob();
2282 0         0 for my $glob (@glob) {
2283 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2284             }
2285 0         0 return @glob;
2286             }
2287             else {
2288 0         0 my $glob = _DOS_like_glob();
2289 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2290 0         0 return $glob;
2291             }
2292             }
2293              
2294             #
2295             # Greek path globbing via File::DosGlob 1.10
2296             #
2297             # Often I confuse "_dosglob" and "_doglob".
2298             # So, I renamed "_dosglob" to "_DOS_like_glob".
2299             #
2300             my %iter;
2301             my %entries;
2302             sub _DOS_like_glob {
2303              
2304             # context (keyed by second cxix argument provided by core)
2305 0     0   0 my($expr,$cxix) = @_;
2306              
2307             # glob without args defaults to $_
2308 0 0       0 $expr = $_ if not defined $expr;
2309              
2310             # represents the current user's home directory
2311             #
2312             # 7.3. Expanding Tildes in Filenames
2313             # in Chapter 7. File Access
2314             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2315             #
2316             # and File::HomeDir, File::HomeDir::Windows module
2317              
2318             # DOS-like system
2319 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2320 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2321             { my_home_MSWin32() }oxmse;
2322             }
2323              
2324             # UNIX-like system
2325 0 0 0     0 else {
  0         0  
2326             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2327             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2328             }
2329 0 0       0  
2330 0 0       0 # assume global context if not provided one
2331             $cxix = '_G_' if not defined $cxix;
2332             $iter{$cxix} = 0 if not exists $iter{$cxix};
2333 0 0       0  
2334 0         0 # if we're just beginning, do it all first
2335             if ($iter{$cxix} == 0) {
2336             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2337             }
2338 0 0       0  
2339 0         0 # chuck it all out, quick or slow
2340 0         0 if (wantarray) {
  0         0  
2341             delete $iter{$cxix};
2342             return @{delete $entries{$cxix}};
2343 0 0       0 }
  0         0  
2344 0         0 else {
  0         0  
2345             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2346             return shift @{$entries{$cxix}};
2347             }
2348 0         0 else {
2349 0         0 # return undef for EOL
2350 0         0 delete $iter{$cxix};
2351             delete $entries{$cxix};
2352             return undef;
2353             }
2354             }
2355             }
2356              
2357             #
2358             # Greek path globbing subroutine
2359             #
2360 0     0   0 sub _do_glob {
2361 0         0  
2362 0         0 my($cond,@expr) = @_;
2363             my @glob = ();
2364             my $fix_drive_relative_paths = 0;
2365 0         0  
2366 0 0       0 OUTER:
2367 0 0       0 for my $expr (@expr) {
2368             next OUTER if not defined $expr;
2369 0         0 next OUTER if $expr eq '';
2370 0         0  
2371 0         0 my @matched = ();
2372 0         0 my @globdir = ();
2373 0         0 my $head = '.';
2374             my $pathsep = '/';
2375             my $tail;
2376 0 0       0  
2377 0         0 # if argument is within quotes strip em and do no globbing
2378 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2379 0 0       0 $expr = $1;
2380 0         0 if ($cond eq 'd') {
2381             if (-d $expr) {
2382             push @glob, $expr;
2383             }
2384 0 0       0 }
2385 0         0 else {
2386             if (-e $expr) {
2387             push @glob, $expr;
2388 0         0 }
2389             }
2390             next OUTER;
2391             }
2392              
2393 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2394 0 0       0 # to h:./*.pm to expand correctly
2395 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2396             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2397             $fix_drive_relative_paths = 1;
2398             }
2399 0 0       0 }
2400 0 0       0  
2401 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2402 0         0 if ($tail eq '') {
2403             push @glob, $expr;
2404 0 0       0 next OUTER;
2405 0 0       0 }
2406 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2407 0         0 if (@globdir = _do_glob('d', $head)) {
2408             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2409             next OUTER;
2410 0 0 0     0 }
2411 0         0 }
2412             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2413 0         0 $head .= $pathsep;
2414             }
2415             $expr = $tail;
2416             }
2417 0 0       0  
2418 0 0       0 # If file component has no wildcards, we can avoid opendir
2419 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2420             if ($head eq '.') {
2421 0 0 0     0 $head = '';
2422 0         0 }
2423             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2424 0         0 $head .= $pathsep;
2425 0 0       0 }
2426 0 0       0 $head .= $expr;
2427 0         0 if ($cond eq 'd') {
2428             if (-d $head) {
2429             push @glob, $head;
2430             }
2431 0 0       0 }
2432 0         0 else {
2433             if (-e $head) {
2434             push @glob, $head;
2435 0         0 }
2436             }
2437 0 0       0 next OUTER;
2438 0         0 }
2439 0         0 opendir(*DIR, $head) or next OUTER;
2440             my @leaf = readdir DIR;
2441 0 0       0 closedir DIR;
2442 0         0  
2443             if ($head eq '.') {
2444 0 0 0     0 $head = '';
2445 0         0 }
2446             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2447             $head .= $pathsep;
2448 0         0 }
2449 0         0  
2450 0         0 my $pattern = '';
2451             while ($expr =~ / \G ($q_char) /oxgc) {
2452             my $char = $1;
2453              
2454             # 6.9. Matching Shell Globs as Regular Expressions
2455             # in Chapter 6. Pattern Matching
2456             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2457 0 0       0 # (and so on)
    0          
    0          
2458 0         0  
2459             if ($char eq '*') {
2460             $pattern .= "(?:$your_char)*",
2461 0         0 }
2462             elsif ($char eq '?') {
2463             $pattern .= "(?:$your_char)?", # DOS style
2464             # $pattern .= "(?:$your_char)", # UNIX style
2465 0         0 }
2466             elsif ((my $fc = Egreek::fc($char)) ne $char) {
2467             $pattern .= $fc;
2468 0         0 }
2469             else {
2470             $pattern .= quotemeta $char;
2471 0     0   0 }
  0         0  
2472             }
2473             my $matchsub = sub { Egreek::fc($_[0]) =~ /\A $pattern \z/xms };
2474              
2475             # if ($@) {
2476             # print STDERR "$0: $@\n";
2477             # next OUTER;
2478             # }
2479 0         0  
2480 0 0 0     0 INNER:
2481 0         0 for my $leaf (@leaf) {
2482             if ($leaf eq '.' or $leaf eq '..') {
2483 0 0 0     0 next INNER;
2484 0         0 }
2485             if ($cond eq 'd' and not -d "$head$leaf") {
2486             next INNER;
2487 0 0       0 }
2488 0         0  
2489 0         0 if (&$matchsub($leaf)) {
2490             push @matched, "$head$leaf";
2491             next INNER;
2492             }
2493              
2494             # [DOS compatibility special case]
2495 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2496              
2497             if (Egreek::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2498             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2499 0 0       0 Egreek::index($pattern,'\\.') != -1 # pattern has a dot.
2500 0         0 ) {
2501 0         0 if (&$matchsub("$leaf.")) {
2502             push @matched, "$head$leaf";
2503             next INNER;
2504             }
2505 0 0       0 }
2506 0         0 }
2507             if (@matched) {
2508             push @glob, @matched;
2509 0 0       0 }
2510 0         0 }
2511 0         0 if ($fix_drive_relative_paths) {
2512             for my $glob (@glob) {
2513             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2514 0         0 }
2515             }
2516             return @glob;
2517             }
2518              
2519             #
2520             # Greek parse line
2521             #
2522 0     0   0 sub _parse_line {
2523              
2524 0         0 my($line) = @_;
2525 0         0  
2526 0         0 $line .= ' ';
2527             my @piece = ();
2528             while ($line =~ /
2529             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2530             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2531 0 0       0 /oxmsg
2532             ) {
2533 0         0 push @piece, defined($1) ? $1 : $2;
2534             }
2535             return @piece;
2536             }
2537              
2538             #
2539             # Greek parse path
2540             #
2541 0     0   0 sub _parse_path {
2542              
2543 0         0 my($path,$pathsep) = @_;
2544 0         0  
2545 0         0 $path .= '/';
2546             my @subpath = ();
2547             while ($path =~ /
2548             ((?: [^\/\\] )+?) [\/\\]
2549 0         0 /oxmsg
2550             ) {
2551             push @subpath, $1;
2552 0         0 }
2553 0         0  
2554 0         0 my $tail = pop @subpath;
2555             my $head = join $pathsep, @subpath;
2556             return $head, $tail;
2557             }
2558              
2559             #
2560             # via File::HomeDir::Windows 1.00
2561             #
2562             sub my_home_MSWin32 {
2563              
2564             # A lot of unix people and unix-derived tools rely on
2565 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2566 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2567             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2568             return $ENV{'HOME'};
2569             }
2570              
2571 0         0 # Do we have a user profile?
2572             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2573             return $ENV{'USERPROFILE'};
2574             }
2575              
2576 0         0 # Some Windows use something like $ENV{'HOME'}
2577             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2578             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2579 0         0 }
2580              
2581             return undef;
2582             }
2583              
2584             #
2585             # via File::HomeDir::Unix 1.00
2586 0     0 0 0 #
2587             sub my_home {
2588 0 0 0     0 my $home;
    0 0        
2589 0         0  
2590             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2591             $home = $ENV{'HOME'};
2592             }
2593              
2594             # This is from the original code, but I'm guessing
2595 0         0 # it means "login directory" and exists on some Unixes.
2596             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2597             $home = $ENV{'LOGDIR'};
2598             }
2599              
2600             ### More-desperate methods
2601              
2602 0         0 # Light desperation on any (Unixish) platform
2603             else {
2604             $home = CORE::eval q{ (getpwuid($<))[7] };
2605             }
2606              
2607 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2608 0         0 # For example, "nobody"-like users might use /nonexistant
2609             if (defined $home and ! -d($home)) {
2610 0         0 $home = undef;
2611             }
2612             return $home;
2613             }
2614              
2615             #
2616             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2617 0     0 0 0 #
2618             sub Egreek::PREMATCH {
2619             return $`;
2620             }
2621              
2622             #
2623             # ${^MATCH}, $MATCH, $& the string that matched
2624 0     0 0 0 #
2625             sub Egreek::MATCH {
2626             return $&;
2627             }
2628              
2629             #
2630             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2631 0     0 0 0 #
2632             sub Egreek::POSTMATCH {
2633             return $';
2634             }
2635              
2636             #
2637             # Greek character to order (with parameter)
2638             #
2639 0 0   0 1 0 sub Greek::ord(;$) {
2640              
2641 0 0       0 local $_ = shift if @_;
2642 0         0  
2643 0         0 if (/\A ($q_char) /oxms) {
2644 0         0 my @ord = unpack 'C*', $1;
2645 0         0 my $ord = 0;
2646             while (my $o = shift @ord) {
2647 0         0 $ord = $ord * 0x100 + $o;
2648             }
2649             return $ord;
2650 0         0 }
2651             else {
2652             return CORE::ord $_;
2653             }
2654             }
2655              
2656             #
2657             # Greek character to order (without parameter)
2658             #
2659 0 0   0 0 0 sub Greek::ord_() {
2660 0         0  
2661 0         0 if (/\A ($q_char) /oxms) {
2662 0         0 my @ord = unpack 'C*', $1;
2663 0         0 my $ord = 0;
2664             while (my $o = shift @ord) {
2665 0         0 $ord = $ord * 0x100 + $o;
2666             }
2667             return $ord;
2668 0         0 }
2669             else {
2670             return CORE::ord $_;
2671             }
2672             }
2673              
2674             #
2675             # Greek reverse
2676             #
2677 0 0   0 0 0 sub Greek::reverse(@) {
2678 0         0  
2679             if (wantarray) {
2680             return CORE::reverse @_;
2681             }
2682             else {
2683              
2684             # One of us once cornered Larry in an elevator and asked him what
2685             # problem he was solving with this, but he looked as far off into
2686             # the distance as he could in an elevator and said, "It seemed like
2687 0         0 # a good idea at the time."
2688              
2689             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2690             }
2691             }
2692              
2693             #
2694             # Greek getc (with parameter, without parameter)
2695             #
2696 0     0 0 0 sub Greek::getc(;*@) {
2697 0 0       0  
2698 0 0 0     0 my($package) = caller;
2699             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2700 0         0 croak 'Too many arguments for Greek::getc' if @_ and not wantarray;
  0         0  
2701 0         0  
2702 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2703 0         0 my $getc = '';
2704 0 0       0 for my $length ($length[0] .. $length[-1]) {
2705 0 0       0 $getc .= CORE::getc($fh);
2706 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2707             if ($getc =~ /\A ${Egreek::dot_s} \z/oxms) {
2708             return wantarray ? ($getc,@_) : $getc;
2709             }
2710 0 0       0 }
2711             }
2712             return wantarray ? ($getc,@_) : $getc;
2713             }
2714              
2715             #
2716             # Greek length by character
2717             #
2718 0 0   0 1 0 sub Greek::length(;$) {
2719              
2720 0         0 local $_ = shift if @_;
2721 0         0  
2722             local @_ = /\G ($q_char) /oxmsg;
2723             return scalar @_;
2724             }
2725              
2726             #
2727             # Greek substr by character
2728             #
2729             BEGIN {
2730              
2731             # P.232 The lvalue Attribute
2732             # in Chapter 6: Subroutines
2733             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2734              
2735             # P.336 The lvalue Attribute
2736             # in Chapter 7: Subroutines
2737             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2738              
2739             # P.144 8.4 Lvalue subroutines
2740             # in Chapter 8: perlsub: Perl subroutines
2741 204 50 0 204 1 157714 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2742              
2743             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2744             # vv----------------------*******
2745             sub Greek::substr($$;$$) %s {
2746              
2747             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2748              
2749             # If the substring is beyond either end of the string, substr() returns the undefined
2750             # value and produces a warning. When used as an lvalue, specifying a substring that
2751             # is entirely outside the string raises an exception.
2752             # http://perldoc.perl.org/functions/substr.html
2753              
2754             # A return with no argument returns the scalar value undef in scalar context,
2755             # an empty list () in list context, and (naturally) nothing at all in void
2756             # context.
2757              
2758             my $offset = $_[1];
2759             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2760             return;
2761             }
2762              
2763             # substr($string,$offset,$length,$replacement)
2764             if (@_ == 4) {
2765             my(undef,undef,$length,$replacement) = @_;
2766             my $substr = join '', splice(@char, $offset, $length, $replacement);
2767             $_[0] = join '', @char;
2768              
2769             # return $substr; this doesn't work, don't say "return"
2770             $substr;
2771             }
2772              
2773             # substr($string,$offset,$length)
2774             elsif (@_ == 3) {
2775             my(undef,undef,$length) = @_;
2776             my $octet_offset = 0;
2777             my $octet_length = 0;
2778             if ($offset == 0) {
2779             $octet_offset = 0;
2780             }
2781             elsif ($offset > 0) {
2782             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2783             }
2784             else {
2785             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2786             }
2787             if ($length == 0) {
2788             $octet_length = 0;
2789             }
2790             elsif ($length > 0) {
2791             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2792             }
2793             else {
2794             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2795             }
2796             CORE::substr($_[0], $octet_offset, $octet_length);
2797             }
2798              
2799             # substr($string,$offset)
2800             else {
2801             my $octet_offset = 0;
2802             if ($offset == 0) {
2803             $octet_offset = 0;
2804             }
2805             elsif ($offset > 0) {
2806             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2807             }
2808             else {
2809             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2810             }
2811             CORE::substr($_[0], $octet_offset);
2812             }
2813             }
2814             END
2815             }
2816              
2817             #
2818             # Greek index by character
2819             #
2820 0     0 1 0 sub Greek::index($$;$) {
2821 0 0       0  
2822 0         0 my $index;
2823             if (@_ == 3) {
2824             $index = Egreek::index($_[0], $_[1], CORE::length(Greek::substr($_[0], 0, $_[2])));
2825 0         0 }
2826             else {
2827             $index = Egreek::index($_[0], $_[1]);
2828 0 0       0 }
2829 0         0  
2830             if ($index == -1) {
2831             return -1;
2832 0         0 }
2833             else {
2834             return Greek::length(CORE::substr $_[0], 0, $index);
2835             }
2836             }
2837              
2838             #
2839             # Greek rindex by character
2840             #
2841 0     0 1 0 sub Greek::rindex($$;$) {
2842 0 0       0  
2843 0         0 my $rindex;
2844             if (@_ == 3) {
2845             $rindex = Egreek::rindex($_[0], $_[1], CORE::length(Greek::substr($_[0], 0, $_[2])));
2846 0         0 }
2847             else {
2848             $rindex = Egreek::rindex($_[0], $_[1]);
2849 0 0       0 }
2850 0         0  
2851             if ($rindex == -1) {
2852             return -1;
2853 0         0 }
2854             else {
2855             return Greek::length(CORE::substr $_[0], 0, $rindex);
2856             }
2857             }
2858              
2859 204     204   1791 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         425  
  204         30758  
2860             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2861             use vars qw($slash); $slash = 'm//';
2862              
2863             # ord() to ord() or Greek::ord()
2864             my $function_ord = 'ord';
2865              
2866             # ord to ord or Greek::ord_
2867             my $function_ord_ = 'ord';
2868              
2869             # reverse to reverse or Greek::reverse
2870             my $function_reverse = 'reverse';
2871              
2872             # getc to getc or Greek::getc
2873             my $function_getc = 'getc';
2874              
2875             # P.1023 Appendix W.9 Multibyte Anchoring
2876             # of ISBN 1-56592-224-7 CJKV Information Processing
2877              
2878 204     204   1679 my $anchor = '';
  204     0   477  
  204         11019739  
2879              
2880             use vars qw($nest);
2881              
2882             # regexp of nested parens in qqXX
2883              
2884             # P.340 Matching Nested Constructs with Embedded Code
2885             # in Chapter 7: Perl
2886             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2887              
2888             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2889             [^\\()] |
2890             \( (?{$nest++}) |
2891             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2892             \\ [^c] |
2893             \\c[\x40-\x5F] |
2894             [\x00-\xFF]
2895             }xms;
2896              
2897             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2898             [^\\{}] |
2899             \{ (?{$nest++}) |
2900             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2901             \\ [^c] |
2902             \\c[\x40-\x5F] |
2903             [\x00-\xFF]
2904             }xms;
2905              
2906             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2907             [^\\\[\]] |
2908             \[ (?{$nest++}) |
2909             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2910             \\ [^c] |
2911             \\c[\x40-\x5F] |
2912             [\x00-\xFF]
2913             }xms;
2914              
2915             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2916             [^\\<>] |
2917             \< (?{$nest++}) |
2918             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2919             \\ [^c] |
2920             \\c[\x40-\x5F] |
2921             [\x00-\xFF]
2922             }xms;
2923              
2924             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2925             (?: ::)? (?:
2926             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2927             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2928             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2929             ))
2930             }xms;
2931              
2932             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2933             (?: ::)? (?:
2934             (?>[0-9]+) |
2935             [^a-zA-Z_0-9\[\]] |
2936             ^[A-Z] |
2937             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2938             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2939             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2940             ))
2941             }xms;
2942              
2943             my $qq_substr = qr{(?> Char::substr | Greek::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2944             }xms;
2945              
2946             # regexp of nested parens in qXX
2947             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2948             [^()] |
2949             \( (?{$nest++}) |
2950             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2951             [\x00-\xFF]
2952             }xms;
2953              
2954             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2955             [^\{\}] |
2956             \{ (?{$nest++}) |
2957             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2958             [\x00-\xFF]
2959             }xms;
2960              
2961             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2962             [^\[\]] |
2963             \[ (?{$nest++}) |
2964             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2965             [\x00-\xFF]
2966             }xms;
2967              
2968             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2969             [^<>] |
2970             \< (?{$nest++}) |
2971             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2972             [\x00-\xFF]
2973             }xms;
2974              
2975             my $matched = '';
2976             my $s_matched = '';
2977              
2978             my $tr_variable = ''; # variable of tr///
2979             my $sub_variable = ''; # variable of s///
2980             my $bind_operator = ''; # =~ or !~
2981              
2982             my @heredoc = (); # here document
2983             my @heredoc_delimiter = ();
2984             my $here_script = ''; # here script
2985              
2986             #
2987             # escape Greek script
2988 0 50   204 0 0 #
2989             sub Greek::escape(;$) {
2990             local($_) = $_[0] if @_;
2991              
2992             # P.359 The Study Function
2993             # in Chapter 7: Perl
2994 204         1679 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2995              
2996             study $_; # Yes, I studied study yesterday.
2997              
2998             # while all script
2999              
3000             # 6.14. Matching from Where the Last Pattern Left Off
3001             # in Chapter 6. Pattern Matching
3002             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3003             # (and so on)
3004              
3005             # one member of Tag-team
3006             #
3007             # P.128 Start of match (or end of previous match): \G
3008             # P.130 Advanced Use of \G with Perl
3009             # in Chapter 3: Overview of Regular Expression Features and Flavors
3010             # P.255 Use leading anchors
3011             # P.256 Expose ^ and \G at the front expressions
3012             # in Chapter 6: Crafting an Efficient Expression
3013             # P.315 "Tag-team" matching with /gc
3014             # in Chapter 7: Perl
3015 204         411 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3016 204         353  
3017 204         695 my $e_script = '';
3018             while (not /\G \z/oxgc) { # member
3019             $e_script .= Greek::escape_token();
3020 74567         118357 }
3021              
3022             return $e_script;
3023             }
3024              
3025             #
3026             # escape Greek token of script
3027             #
3028             sub Greek::escape_token {
3029              
3030 204     74567 0 3796 # \n output here document
3031              
3032             my $ignore_modules = join('|', qw(
3033             utf8
3034             bytes
3035             charnames
3036             I18N::Japanese
3037             I18N::Collate
3038             I18N::JExt
3039             File::DosGlob
3040             Wild
3041             Wildcard
3042             Japanese
3043             ));
3044              
3045             # another member of Tag-team
3046             #
3047             # P.315 "Tag-team" matching with /gc
3048             # in Chapter 7: Perl
3049 74567 100 100     92827 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    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          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3050 74567         3407866  
3051 12500 100       29876 if (/\G ( \n ) /oxgc) { # another member (and so on)
3052 12500         22491 my $heredoc = '';
3053             if (scalar(@heredoc_delimiter) >= 1) {
3054 174         224 $slash = 'm//';
3055 174         431  
3056             $heredoc = join '', @heredoc;
3057             @heredoc = ();
3058 174         297  
3059 174         470 # skip here document
3060             for my $heredoc_delimiter (@heredoc_delimiter) {
3061 174         1220 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3062             }
3063 174         1497 @heredoc_delimiter = ();
3064              
3065 174         743 $here_script = '';
3066             }
3067             return "\n" . $heredoc;
3068             }
3069 12500         40477  
3070             # ignore space, comment
3071             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3072              
3073             # if (, elsif (, unless (, while (, until (, given (, and when (
3074              
3075             # given, when
3076              
3077             # P.225 The given Statement
3078             # in Chapter 15: Smart Matching and given-when
3079             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3080              
3081             # P.133 The given Statement
3082             # in Chapter 4: Statements and Declarations
3083             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3084 17907         75205  
3085 1400         3366 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3086             $slash = 'm//';
3087             return $1;
3088             }
3089              
3090             # scalar variable ($scalar = ...) =~ tr///;
3091             # scalar variable ($scalar = ...) =~ s///;
3092              
3093             # state
3094              
3095             # P.68 Persistent, Private Variables
3096             # in Chapter 4: Subroutines
3097             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3098              
3099             # P.160 Persistent Lexically Scoped Variables: state
3100             # in Chapter 4: Statements and Declarations
3101             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3102              
3103             # (and so on)
3104 1400         4714  
3105             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3106 86 50       190 my $e_string = e_string($1);
    50          
3107 86         2265  
3108 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3109 0         0 $tr_variable = $e_string . e_string($1);
3110 0         0 $bind_operator = $2;
3111             $slash = 'm//';
3112             return '';
3113 0         0 }
3114 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3115 0         0 $sub_variable = $e_string . e_string($1);
3116 0         0 $bind_operator = $2;
3117             $slash = 'm//';
3118             return '';
3119 0         0 }
3120 86         155 else {
3121             $slash = 'div';
3122             return $e_string;
3123             }
3124             }
3125              
3126 86         288 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egreek::PREMATCH()
3127 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3128             $slash = 'div';
3129             return q{Egreek::PREMATCH()};
3130             }
3131              
3132 4         13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egreek::MATCH()
3133 28         55 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3134             $slash = 'div';
3135             return q{Egreek::MATCH()};
3136             }
3137              
3138 28         87 # $', ${'} --> $', ${'}
3139 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3140             $slash = 'div';
3141             return $1;
3142             }
3143              
3144 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egreek::POSTMATCH()
3145 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3146             $slash = 'div';
3147             return q{Egreek::POSTMATCH()};
3148             }
3149              
3150             # scalar variable $scalar =~ tr///;
3151             # scalar variable $scalar =~ s///;
3152             # substr() =~ tr///;
3153 3         11 # substr() =~ s///;
3154             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3155 1671 100       5317 my $scalar = e_string($1);
    100          
3156 1671         6683  
3157 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3158 1         3 $tr_variable = $scalar;
3159 1         2 $bind_operator = $1;
3160             $slash = 'm//';
3161             return '';
3162 1         3 }
3163 61         121 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3164 61         117 $sub_variable = $scalar;
3165 61         95 $bind_operator = $1;
3166             $slash = 'm//';
3167             return '';
3168 61         168 }
3169 1609         2371 else {
3170             $slash = 'div';
3171             return $scalar;
3172             }
3173             }
3174              
3175 1609         4246 # end of statement
3176             elsif (/\G ( [,;] ) /oxgc) {
3177             $slash = 'm//';
3178 4982         7333  
3179             # clear tr/// variable
3180             $tr_variable = '';
3181 4982         7108  
3182             # clear s/// variable
3183 4982         5915 $sub_variable = '';
3184              
3185 4982         5992 $bind_operator = '';
3186              
3187             return $1;
3188             }
3189              
3190 4982         33861 # bareword
3191             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3192             return $1;
3193             }
3194              
3195 0         0 # $0 --> $0
3196 2         7 elsif (/\G ( \$ 0 ) /oxmsgc) {
3197             $slash = 'div';
3198             return $1;
3199 2         7 }
3200 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3201             $slash = 'div';
3202             return $1;
3203             }
3204              
3205 0         0 # $$ --> $$
3206 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3207             $slash = 'div';
3208             return $1;
3209             }
3210              
3211             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3212 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3213 4         8 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3214             $slash = 'div';
3215             return e_capture($1);
3216 4         10 }
3217 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3218             $slash = 'div';
3219             return e_capture($1);
3220             }
3221              
3222 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3223 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3224             $slash = 'div';
3225             return e_capture($1.'->'.$2);
3226             }
3227              
3228 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3229 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3230             $slash = 'div';
3231             return e_capture($1.'->'.$2);
3232             }
3233              
3234 0         0 # $$foo
3235 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3236             $slash = 'div';
3237             return e_capture($1);
3238             }
3239              
3240 0         0 # ${ foo }
3241 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3242             $slash = 'div';
3243             return '${' . $1 . '}';
3244             }
3245              
3246 0         0 # ${ ... }
3247 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3248             $slash = 'div';
3249             return e_capture($1);
3250             }
3251              
3252             # variable or function
3253 0         0 # $ @ % & * $ #
3254 42         121 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) {
3255             $slash = 'div';
3256             return $1;
3257             }
3258             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3259 42         143 # $ @ # \ ' " / ? ( ) [ ] < >
3260 61         137 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3261             $slash = 'div';
3262             return $1;
3263             }
3264              
3265 61         230 # while ()
3266             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3267             return $1;
3268             }
3269              
3270             # while () --- glob
3271              
3272             # avoid "Error: Runtime exception" of perl version 5.005_03
3273 0         0  
3274             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3275             return 'while ($_ = Egreek::glob("' . $1 . '"))';
3276             }
3277              
3278 0         0 # while (glob)
3279             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3280             return 'while ($_ = Egreek::glob_)';
3281             }
3282              
3283 0         0 # while (glob(WILDCARD))
3284             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3285             return 'while ($_ = Egreek::glob';
3286             }
3287 0         0  
  247         657  
3288             # doit if, doit unless, doit while, doit until, doit for, doit when
3289             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3290 247         966  
  18         31  
3291 18         58 # subroutines of package Egreek
  0         0  
3292 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         20  
3293 13         31 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3294 0         0 elsif (/\G \b Greek::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         178  
3295 114         327 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         6  
3296 2         5 elsif (/\G \b Greek::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Greek::escape'; }
  0         0  
3297 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3298 2         9 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::chop'; }
  0         0  
3299 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3300 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3301 0         0 elsif (/\G \b Greek::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Greek::index'; }
  2         5  
3302 2         8 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::index'; }
  0         0  
3303 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3304 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3305 0         0 elsif (/\G \b Greek::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Greek::rindex'; }
  1         3  
3306 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::rindex'; }
  0         0  
3307 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egreek::lc'; }
  1         2  
3308 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egreek::lcfirst'; }
  0         0  
3309 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egreek::uc'; }
  6         11  
3310             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egreek::ucfirst'; }
3311             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egreek::fc'; }
3312 6         19  
  0         0  
3313 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3314 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3315 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3316 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3317 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3318 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3319             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3320 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  
3321 0         0  
  0         0  
3322 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3323 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3324 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3325 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3326 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3327             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3328             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3329 0         0  
  0         0  
3330 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3331 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3332 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3333             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3334 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3335 2         7  
  2         6  
3336 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         79  
3337 36         117 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         168  
3338 2         10 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egreek::chr'; }
  8         16  
3339 8         24 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3340 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3341 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egreek::glob'; }
  0         0  
3342 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::lc_'; }
  0         0  
3343 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::lcfirst_'; }
  0         0  
3344 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::uc_'; }
  0         0  
3345 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::ucfirst_'; }
  0         0  
3346             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::fc_'; }
3347 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3348 0         0  
  0         0  
3349 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3350 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3351 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::chr_'; }
  0         0  
3352 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3353 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3354 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egreek::glob_'; }
  8         22  
3355             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3356             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3357 8         33 # split
3358             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3359 87         231 $slash = 'm//';
3360 87         151  
3361 87         355 my $e = '';
3362             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3363             $e .= $1;
3364             }
3365 85 100       340  
  87 100       5726  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3366             # end of split
3367             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Egreek::split' . $e; }
3368 2         9  
3369             # split scalar value
3370             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Egreek::split' . $e . e_string($1); }
3371 1         30  
3372 0         0 # split literal space
3373 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Egreek::split' . $e . qq {qq$1 $2}; }
3374 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Egreek::split' . $e . qq{$1qq$2 $3}; }
3375 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Egreek::split' . $e . qq{$1qq$2 $3}; }
3376 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Egreek::split' . $e . qq{$1qq$2 $3}; }
3377 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Egreek::split' . $e . qq{$1qq$2 $3}; }
3378 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Egreek::split' . $e . qq{$1qq$2 $3}; }
3379 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Egreek::split' . $e . qq {q$1 $2}; }
3380 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Egreek::split' . $e . qq {$1q$2 $3}; }
3381 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Egreek::split' . $e . qq {$1q$2 $3}; }
3382 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Egreek::split' . $e . qq {$1q$2 $3}; }
3383 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Egreek::split' . $e . qq {$1q$2 $3}; }
3384 10         44 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Egreek::split' . $e . qq {$1q$2 $3}; }
3385             elsif (/\G ' [ ] ' /oxgc) { return 'Egreek::split' . $e . qq {' '}; }
3386             elsif (/\G " [ ] " /oxgc) { return 'Egreek::split' . $e . qq {" "}; }
3387              
3388 0 0       0 # split qq//
  0         0  
3389             elsif (/\G \b (qq) \b /oxgc) {
3390 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3391 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3392 0         0 while (not /\G \z/oxgc) {
3393 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3394 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3395 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3396 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3397 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3398             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3399 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3400             }
3401             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3402             }
3403             }
3404              
3405 0 50       0 # split qr//
  12         421  
3406             elsif (/\G \b (qr) \b /oxgc) {
3407 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3408 12 50       60 else {
  12 50       3305  
    50          
    50          
    50          
    50          
    50          
    50          
3409 0         0 while (not /\G \z/oxgc) {
3410 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3411 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3412 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3413 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3414 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3415 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3416             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3417 12         79 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3418             }
3419             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3420             }
3421             }
3422              
3423 0 0       0 # split q//
  0         0  
3424             elsif (/\G \b (q) \b /oxgc) {
3425 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3426 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3427 0         0 while (not /\G \z/oxgc) {
3428 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3429 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3430 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3431 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3432 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3433             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3434 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3435             }
3436             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3437             }
3438             }
3439              
3440 0 50       0 # split m//
  18         477  
3441             elsif (/\G \b (m) \b /oxgc) {
3442 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3443 18 50       74 else {
  18 50       3894  
    50          
    50          
    50          
    50          
    50          
    50          
3444 0         0 while (not /\G \z/oxgc) {
3445 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3446 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3447 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3448 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3449 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3450 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3451             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3452 18         106 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3453             }
3454             die __FILE__, ": Search pattern not terminated\n";
3455             }
3456             }
3457              
3458 0         0 # split ''
3459 0         0 elsif (/\G (\') /oxgc) {
3460 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3461 0         0 while (not /\G \z/oxgc) {
3462 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3463 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3464             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3465 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3466             }
3467             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3468             }
3469              
3470 0         0 # split ""
3471 0         0 elsif (/\G (\") /oxgc) {
3472 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3473 0         0 while (not /\G \z/oxgc) {
3474 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3475 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3476             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3477 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3478             }
3479             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3480             }
3481              
3482 0         0 # split //
3483 44         115 elsif (/\G (\/) /oxgc) {
3484 44 50       171 my $regexp = '';
  381 50       2603  
    100          
    50          
3485 0         0 while (not /\G \z/oxgc) {
3486 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3487 44         185 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3488             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3489 337         766 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3490             }
3491             die __FILE__, ": Search pattern not terminated\n";
3492             }
3493             }
3494              
3495             # tr/// or y///
3496              
3497             # about [cdsrbB]* (/B modifier)
3498             #
3499             # P.559 appendix C
3500             # of ISBN 4-89052-384-7 Programming perl
3501             # (Japanese title is: Perl puroguramingu)
3502 0         0  
3503             elsif (/\G \b ( tr | y ) \b /oxgc) {
3504             my $ope = $1;
3505 3 50       11  
3506 3         45 # $1 $2 $3 $4 $5 $6
3507 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3508             my @tr = ($tr_variable,$2);
3509             return e_tr(@tr,'',$4,$6);
3510 0         0 }
3511 3         5 else {
3512 3 50       9 my $e = '';
  3 50       242  
    50          
    50          
    50          
    50          
3513             while (not /\G \z/oxgc) {
3514 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3515 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3516 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3517 0         0 while (not /\G \z/oxgc) {
3518 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3519 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3520 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3521 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3522             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3523 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3524             }
3525             die __FILE__, ": Transliteration replacement not terminated\n";
3526 0         0 }
3527 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3528 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3529 0         0 while (not /\G \z/oxgc) {
3530 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3531 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3532 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3533 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3534             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3535 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3536             }
3537             die __FILE__, ": Transliteration replacement not terminated\n";
3538 0         0 }
3539 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3540 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3541 0         0 while (not /\G \z/oxgc) {
3542 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3543 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3544 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3545 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3546             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3547 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3548             }
3549             die __FILE__, ": Transliteration replacement not terminated\n";
3550 0         0 }
3551 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3552 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3553 0         0 while (not /\G \z/oxgc) {
3554 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3555 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3556 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3557 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3558             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3559 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3560             }
3561             die __FILE__, ": Transliteration replacement not terminated\n";
3562             }
3563 0         0 # $1 $2 $3 $4 $5 $6
3564 3         11 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3565             my @tr = ($tr_variable,$2);
3566             return e_tr(@tr,'',$4,$6);
3567 3         8 }
3568             }
3569             die __FILE__, ": Transliteration pattern not terminated\n";
3570             }
3571             }
3572              
3573 0         0 # qq//
3574             elsif (/\G \b (qq) \b /oxgc) {
3575             my $ope = $1;
3576 2179 50       5602  
3577 2179         4565 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3578 0         0 if (/\G (\#) /oxgc) { # qq# #
3579 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3580 0         0 while (not /\G \z/oxgc) {
3581 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3582 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3583             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3584 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3585             }
3586             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3587             }
3588 0         0  
3589 2179         3138 else {
3590 2179 50       5485 my $e = '';
  2179 50       8306  
    100          
    50          
    50          
    0          
3591             while (not /\G \z/oxgc) {
3592             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3593              
3594 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3595 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3596 0         0 my $qq_string = '';
3597 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3598 0         0 while (not /\G \z/oxgc) {
3599 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3600             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3601 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3602 0         0 elsif (/\G (\)) /oxgc) {
3603             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3604 0         0 else { $qq_string .= $1; }
3605             }
3606 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3607             }
3608             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3609             }
3610              
3611 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3612 2149         3070 elsif (/\G (\{) /oxgc) { # qq { }
3613 2149         4237 my $qq_string = '';
3614 2149 100       4810 local $nest = 1;
  83963 50       304728  
    100          
    100          
    50          
3615 722         1562 while (not /\G \z/oxgc) {
3616 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1548  
3617             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3618 1153 100       2159 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3302         5278  
3619 2149         4387 elsif (/\G (\}) /oxgc) {
3620             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3621 1153         2287 else { $qq_string .= $1; }
3622             }
3623 78786         165937 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3624             }
3625             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3626             }
3627              
3628 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3629 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3630 0         0 my $qq_string = '';
3631 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3632 0         0 while (not /\G \z/oxgc) {
3633 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3634             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3635 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3636 0         0 elsif (/\G (\]) /oxgc) {
3637             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3638 0         0 else { $qq_string .= $1; }
3639             }
3640 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3641             }
3642             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3643             }
3644              
3645 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3646 30         102 elsif (/\G (\<) /oxgc) { # qq < >
3647 30         126 my $qq_string = '';
3648 30 100       102 local $nest = 1;
  1166 50       3912  
    50          
    100          
    50          
3649 22         53 while (not /\G \z/oxgc) {
3650 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3651             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3652 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         66  
3653 30         82 elsif (/\G (\>) /oxgc) {
3654             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3655 0         0 else { $qq_string .= $1; }
3656             }
3657 1114         2113 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3658             }
3659             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3660             }
3661              
3662 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3663 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3664 0         0 my $delimiter = $1;
3665 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3666 0         0 while (not /\G \z/oxgc) {
3667 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3668 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3669             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3670 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3671             }
3672             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3673 0         0 }
3674             }
3675             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3676             }
3677             }
3678              
3679 0         0 # qr//
3680 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3681 0         0 my $ope = $1;
3682             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3683             return e_qr($ope,$1,$3,$2,$4);
3684 0         0 }
3685 0         0 else {
3686 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3687 0         0 while (not /\G \z/oxgc) {
3688 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3689 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3690 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3691 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3692 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3693 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3694             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3695 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3696             }
3697             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3698             }
3699             }
3700              
3701 0         0 # qw//
3702 16 50       51 elsif (/\G \b (qw) \b /oxgc) {
3703 16         105 my $ope = $1;
3704             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3705             return e_qw($ope,$1,$3,$2);
3706 0         0 }
3707 16         34 else {
3708 16 50       52 my $e = '';
  16 50       99  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3709             while (not /\G \z/oxgc) {
3710 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3711 16         90  
3712             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3713 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3714 0         0  
3715             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3716 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3717 0         0  
3718             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3719 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3720 0         0  
3721             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3722 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3723 0         0  
3724             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3725 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3726             }
3727             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3728             }
3729             }
3730              
3731 0         0 # qx//
3732 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3733 0         0 my $ope = $1;
3734             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3735             return e_qq($ope,$1,$3,$2);
3736 0         0 }
3737 0         0 else {
3738 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3739 0         0 while (not /\G \z/oxgc) {
3740 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3741 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3742 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3743 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3744 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3745             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3746 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3747             }
3748             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3749             }
3750             }
3751              
3752 0         0 # q//
3753             elsif (/\G \b (q) \b /oxgc) {
3754             my $ope = $1;
3755              
3756             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3757              
3758             # avoid "Error: Runtime exception" of perl version 5.005_03
3759 410 50       1176 # (and so on)
3760 410         1371  
3761 0         0 if (/\G (\#) /oxgc) { # q# #
3762 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3763 0         0 while (not /\G \z/oxgc) {
3764 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3765 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3766             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3767 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3768             }
3769             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3770             }
3771 0         0  
3772 410         669 else {
3773 410 50       1257 my $e = '';
  410 50       2459  
    100          
    50          
    100          
    50          
3774             while (not /\G \z/oxgc) {
3775             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3776              
3777 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3778 0         0 elsif (/\G (\() /oxgc) { # q ( )
3779 0         0 my $q_string = '';
3780 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3781 0         0 while (not /\G \z/oxgc) {
3782 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3783 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3784             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3785 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3786 0         0 elsif (/\G (\)) /oxgc) {
3787             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3788 0         0 else { $q_string .= $1; }
3789             }
3790 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3791             }
3792             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3793             }
3794              
3795 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3796 404         709 elsif (/\G (\{) /oxgc) { # q { }
3797 404         716 my $q_string = '';
3798 404 50       1453 local $nest = 1;
  6757 50       44949  
    50          
    100          
    100          
    50          
3799 0         0 while (not /\G \z/oxgc) {
3800 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3801 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         234  
3802             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3803 107 100       203 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1165  
3804 404         1050 elsif (/\G (\}) /oxgc) {
3805             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3806 107         214 else { $q_string .= $1; }
3807             }
3808 6139         13091 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3809             }
3810             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3811             }
3812              
3813 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3814 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3815 0         0 my $q_string = '';
3816 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3817 0         0 while (not /\G \z/oxgc) {
3818 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3819 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3820             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3821 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3822 0         0 elsif (/\G (\]) /oxgc) {
3823             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3824 0         0 else { $q_string .= $1; }
3825             }
3826 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3827             }
3828             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3829             }
3830              
3831 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3832 5         11 elsif (/\G (\<) /oxgc) { # q < >
3833 5         12 my $q_string = '';
3834 5 50       19 local $nest = 1;
  88 50       453  
    50          
    50          
    100          
    50          
3835 0         0 while (not /\G \z/oxgc) {
3836 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3837 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3838             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3839 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         16  
3840 5         17 elsif (/\G (\>) /oxgc) {
3841             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3842 0         0 else { $q_string .= $1; }
3843             }
3844 83         215 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3845             }
3846             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3847             }
3848              
3849 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3850 1         2 elsif (/\G (\S) /oxgc) { # q * *
3851 1         2 my $delimiter = $1;
3852 1 50       4 my $q_string = '';
  14 50       72  
    100          
    50          
3853 0         0 while (not /\G \z/oxgc) {
3854 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3855 1         5 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3856             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3857 13         25 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3858             }
3859             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3860 0         0 }
3861             }
3862             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3863             }
3864             }
3865              
3866 0         0 # m//
3867 209 50       541 elsif (/\G \b (m) \b /oxgc) {
3868 209         1326 my $ope = $1;
3869             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3870             return e_qr($ope,$1,$3,$2,$4);
3871 0         0 }
3872 209         334 else {
3873 209 50       609 my $e = '';
  209 50       11783  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3874 0         0 while (not /\G \z/oxgc) {
3875 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3876 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3877 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3878 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3879 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3880 10         30 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3881 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3882             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3883 199         766 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3884             }
3885             die __FILE__, ": Search pattern not terminated\n";
3886             }
3887             }
3888              
3889             # s///
3890              
3891             # about [cegimosxpradlunbB]* (/cg modifier)
3892             #
3893             # P.67 Pattern-Matching Operators
3894             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3895 0         0  
3896             elsif (/\G \b (s) \b /oxgc) {
3897             my $ope = $1;
3898 97 100       538  
3899 97         1619 # $1 $2 $3 $4 $5 $6
3900             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3901             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3902 1         5 }
3903 96         202 else {
3904 96 50       349 my $e = '';
  96 50       12925  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3905             while (not /\G \z/oxgc) {
3906 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3907 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3908 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3909             while (not /\G \z/oxgc) {
3910 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3911 0         0 # $1 $2 $3 $4
3912 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3916 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3917 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3918 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3919             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3920 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3921             }
3922             die __FILE__, ": Substitution replacement not terminated\n";
3923 0         0 }
3924 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3925 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3926             while (not /\G \z/oxgc) {
3927 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3928 0         0 # $1 $2 $3 $4
3929 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3937 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3938             }
3939             die __FILE__, ": Substitution replacement not terminated\n";
3940 0         0 }
3941 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3942 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3943             while (not /\G \z/oxgc) {
3944 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3945 0         0 # $1 $2 $3 $4
3946 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3952 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3953             }
3954             die __FILE__, ": Substitution replacement not terminated\n";
3955 0         0 }
3956 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3957 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3958             while (not /\G \z/oxgc) {
3959 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3960 0         0 # $1 $2 $3 $4
3961 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3969 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3970             }
3971             die __FILE__, ": Substitution replacement not terminated\n";
3972             }
3973 0         0 # $1 $2 $3 $4 $5 $6
3974             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3975             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3976             }
3977 21         64 # $1 $2 $3 $4 $5 $6
3978             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3979             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3980             }
3981 0         0 # $1 $2 $3 $4 $5 $6
3982             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3983             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3984             }
3985 0         0 # $1 $2 $3 $4 $5 $6
3986             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3987             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3988 75         379 }
3989             }
3990             die __FILE__, ": Substitution pattern not terminated\n";
3991             }
3992             }
3993 0         0  
3994 0         0 # require ignore module
3995 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3996             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3997             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3998 0         0  
3999 37         307 # use strict; --> use strict; no strict qw(refs);
4000 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4001             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4002             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4003              
4004 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4005 2         27 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4006             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4007             return "use $1; no strict qw(refs);";
4008 0         0 }
4009             else {
4010             return "use $1;";
4011             }
4012 2 0 0     13 }
      0        
4013 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4014             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4015             return "use $1; no strict qw(refs);";
4016 0         0 }
4017             else {
4018             return "use $1;";
4019             }
4020             }
4021 0         0  
4022 2         15 # ignore use module
4023 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4024             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4025             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4026 0         0  
4027 0         0 # ignore no module
4028 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4029             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4030             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4031 0         0  
4032             # use else
4033             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4034 0         0  
4035             # use else
4036             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4037              
4038 2         15 # ''
4039 848         2049 elsif (/\G (?
4040 848 100       2653 my $q_string = '';
  8241 100       27039  
    100          
    50          
4041 4         11 while (not /\G \z/oxgc) {
4042 48         85 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4043 848         2199 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4044             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4045 7341         15383 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4046             }
4047             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4048             }
4049              
4050 0         0 # ""
4051 1782         4972 elsif (/\G (\") /oxgc) {
4052 1782 100       4378 my $qq_string = '';
  34702 100       100975  
    100          
    50          
4053 67         175 while (not /\G \z/oxgc) {
4054 12         23 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4055 1782         21384 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4056             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4057 32841         77239 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4058             }
4059             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4060             }
4061              
4062 0         0 # ``
4063 1         3 elsif (/\G (\`) /oxgc) {
4064 1 50       3 my $qx_string = '';
  19 50       104  
    100          
    50          
4065 0         0 while (not /\G \z/oxgc) {
4066 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4067 1         5 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4068             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4069 18         35 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4070             }
4071             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4072             }
4073              
4074 0         0 # // --- not divide operator (num / num), not defined-or
4075 453         1355 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4076 453 50       1351 my $regexp = '';
  4496 50       15929  
    100          
    50          
4077 0         0 while (not /\G \z/oxgc) {
4078 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4079 453         1634 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4080             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4081 4043         8337 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4082             }
4083             die __FILE__, ": Search pattern not terminated\n";
4084             }
4085              
4086 0         0 # ?? --- not conditional operator (condition ? then : else)
4087 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4088 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4089 0         0 while (not /\G \z/oxgc) {
4090 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4091 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4092             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4093 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4094             }
4095             die __FILE__, ": Search pattern not terminated\n";
4096             }
4097 0         0  
  0         0  
4098             # <<>> (a safer ARGV)
4099             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4100 0         0  
  0         0  
4101             # << (bit shift) --- not here document
4102             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4103              
4104 0         0 # <<~'HEREDOC'
4105 6         10 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4106 6         12 $slash = 'm//';
4107             my $here_quote = $1;
4108             my $delimiter = $2;
4109 6 50       11  
4110 6         13 # get here document
4111 6         30 if ($here_script eq '') {
4112             $here_script = CORE::substr $_, pos $_;
4113 6 50       32 $here_script =~ s/.*?\n//oxm;
4114 6         56 }
4115 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4116 6         9 my $heredoc = $1;
4117 6         55 my $indent = $2;
4118 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4119             push @heredoc, $heredoc . qq{\n$delimiter\n};
4120             push @heredoc_delimiter, qq{\\s*$delimiter};
4121 6         13 }
4122             else {
4123 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4124             }
4125             return qq{<<'$delimiter'};
4126             }
4127              
4128             # <<~\HEREDOC
4129              
4130             # P.66 2.6.6. "Here" Documents
4131             # in Chapter 2: Bits and Pieces
4132             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4133              
4134             # P.73 "Here" Documents
4135             # in Chapter 2: Bits and Pieces
4136             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4137 6         23  
4138 3         9 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4139 3         4 $slash = 'm//';
4140             my $here_quote = $1;
4141             my $delimiter = $2;
4142 3 50       6  
4143 3         10 # get here document
4144 3         186 if ($here_script eq '') {
4145             $here_script = CORE::substr $_, pos $_;
4146 3 50       21 $here_script =~ s/.*?\n//oxm;
4147 3         50 }
4148 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4149 3         6 my $heredoc = $1;
4150 3         38 my $indent = $2;
4151 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
4152             push @heredoc, $heredoc . qq{\n$delimiter\n};
4153             push @heredoc_delimiter, qq{\\s*$delimiter};
4154 3         9 }
4155             else {
4156 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4157             }
4158             return qq{<<\\$delimiter};
4159             }
4160              
4161 3         13 # <<~"HEREDOC"
4162 6         11 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4163 6         12 $slash = 'm//';
4164             my $here_quote = $1;
4165             my $delimiter = $2;
4166 6 50       8  
4167 6         12 # get here document
4168 6         28 if ($here_script eq '') {
4169             $here_script = CORE::substr $_, pos $_;
4170 6 50       31 $here_script =~ s/.*?\n//oxm;
4171 6         64 }
4172 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4173 6         8 my $heredoc = $1;
4174 6         166 my $indent = $2;
4175 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4176             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4177             push @heredoc_delimiter, qq{\\s*$delimiter};
4178 6         15 }
4179             else {
4180 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4181             }
4182             return qq{<<"$delimiter"};
4183             }
4184              
4185 6         26 # <<~HEREDOC
4186 3         8 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4187 3         6 $slash = 'm//';
4188             my $here_quote = $1;
4189             my $delimiter = $2;
4190 3 50       6  
4191 3         7 # get here document
4192 3         13 if ($here_script eq '') {
4193             $here_script = CORE::substr $_, pos $_;
4194 3 50       23 $here_script =~ s/.*?\n//oxm;
4195 3         39 }
4196 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4197 3         5 my $heredoc = $1;
4198 3         36 my $indent = $2;
4199 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
4200             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4201             push @heredoc_delimiter, qq{\\s*$delimiter};
4202 3         9 }
4203             else {
4204 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4205             }
4206             return qq{<<$delimiter};
4207             }
4208              
4209 3         12 # <<~`HEREDOC`
4210 6         14 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4211 6         13 $slash = 'm//';
4212             my $here_quote = $1;
4213             my $delimiter = $2;
4214 6 50       11  
4215 6         13 # get here document
4216 6         18 if ($here_script eq '') {
4217             $here_script = CORE::substr $_, pos $_;
4218 6 50       31 $here_script =~ s/.*?\n//oxm;
4219 6         56 }
4220 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4221 6         25 my $heredoc = $1;
4222 6         52 my $indent = $2;
4223 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4224             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4225             push @heredoc_delimiter, qq{\\s*$delimiter};
4226 6         14 }
4227             else {
4228 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4229             }
4230             return qq{<<`$delimiter`};
4231             }
4232              
4233 6         21 # <<'HEREDOC'
4234 72         148 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4235 72         144 $slash = 'm//';
4236             my $here_quote = $1;
4237             my $delimiter = $2;
4238 72 50       118  
4239 72         211 # get here document
4240 72         454 if ($here_script eq '') {
4241             $here_script = CORE::substr $_, pos $_;
4242 72 50       394 $here_script =~ s/.*?\n//oxm;
4243 72         550 }
4244 72         233 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4245             push @heredoc, $1 . qq{\n$delimiter\n};
4246             push @heredoc_delimiter, $delimiter;
4247 72         111 }
4248             else {
4249 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4250             }
4251             return $here_quote;
4252             }
4253              
4254             # <<\HEREDOC
4255              
4256             # P.66 2.6.6. "Here" Documents
4257             # in Chapter 2: Bits and Pieces
4258             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4259              
4260             # P.73 "Here" Documents
4261             # in Chapter 2: Bits and Pieces
4262             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4263 72         318  
4264 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4265 0         0 $slash = 'm//';
4266             my $here_quote = $1;
4267             my $delimiter = $2;
4268 0 0       0  
4269 0         0 # get here document
4270 0         0 if ($here_script eq '') {
4271             $here_script = CORE::substr $_, pos $_;
4272 0 0       0 $here_script =~ s/.*?\n//oxm;
4273 0         0 }
4274 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4275             push @heredoc, $1 . qq{\n$delimiter\n};
4276             push @heredoc_delimiter, $delimiter;
4277 0         0 }
4278             else {
4279 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4280             }
4281             return $here_quote;
4282             }
4283              
4284 0         0 # <<"HEREDOC"
4285 36         16157 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4286 36         91 $slash = 'm//';
4287             my $here_quote = $1;
4288             my $delimiter = $2;
4289 36 50       76  
4290 36         95 # get here document
4291 36         313 if ($here_script eq '') {
4292             $here_script = CORE::substr $_, pos $_;
4293 36 50       257 $here_script =~ s/.*?\n//oxm;
4294 36         669 }
4295 36         137 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4296             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4297             push @heredoc_delimiter, $delimiter;
4298 36         110 }
4299             else {
4300 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4301             }
4302             return $here_quote;
4303             }
4304              
4305 36         161 # <
4306 42         96 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4307 42         88 $slash = 'm//';
4308             my $here_quote = $1;
4309             my $delimiter = $2;
4310 42 50       74  
4311 42         100 # get here document
4312 42         285 if ($here_script eq '') {
4313             $here_script = CORE::substr $_, pos $_;
4314 42 50       317 $here_script =~ s/.*?\n//oxm;
4315 42         578 }
4316 42         223 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4317             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4318             push @heredoc_delimiter, $delimiter;
4319 42         109 }
4320             else {
4321 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4322             }
4323             return $here_quote;
4324             }
4325              
4326 42         177 # <<`HEREDOC`
4327 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4328 0         0 $slash = 'm//';
4329             my $here_quote = $1;
4330             my $delimiter = $2;
4331 0 0       0  
4332 0         0 # get here document
4333 0         0 if ($here_script eq '') {
4334             $here_script = CORE::substr $_, pos $_;
4335 0 0       0 $here_script =~ s/.*?\n//oxm;
4336 0         0 }
4337 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4338             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4339             push @heredoc_delimiter, $delimiter;
4340 0         0 }
4341             else {
4342 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4343             }
4344             return $here_quote;
4345             }
4346              
4347 0         0 # <<= <=> <= < operator
4348             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4349             return $1;
4350             }
4351              
4352 12         221 #
4353             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4354             return $1;
4355             }
4356              
4357             # --- glob
4358              
4359             # avoid "Error: Runtime exception" of perl version 5.005_03
4360 0         0  
4361             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4362             return 'Egreek::glob("' . $1 . '")';
4363             }
4364 0         0  
4365             # __DATA__
4366             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4367 0         0  
4368             # __END__
4369             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4370              
4371             # \cD Control-D
4372              
4373             # P.68 2.6.8. Other Literal Tokens
4374             # in Chapter 2: Bits and Pieces
4375             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4376              
4377             # P.76 Other Literal Tokens
4378             # in Chapter 2: Bits and Pieces
4379 204         1657 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4380              
4381             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4382 0         0  
4383             # \cZ Control-Z
4384             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4385              
4386             # any operator before div
4387             elsif (/\G (
4388             -- | \+\+ |
4389 0         0 [\)\}\]]
  5076         13686  
4390              
4391             ) /oxgc) { $slash = 'div'; return $1; }
4392              
4393             # yada-yada or triple-dot operator
4394             elsif (/\G (
4395 5076         24598 \.\.\.
  7         13  
4396              
4397             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4398              
4399             # any operator before m//
4400              
4401             # //, //= (defined-or)
4402              
4403             # P.164 Logical Operators
4404             # in Chapter 10: More Control Structures
4405             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4406              
4407             # P.119 C-Style Logical (Short-Circuit) Operators
4408             # in Chapter 3: Unary and Binary Operators
4409             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4410              
4411             # (and so on)
4412              
4413             # ~~
4414              
4415             # P.221 The Smart Match Operator
4416             # in Chapter 15: Smart Matching and given-when
4417             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4418              
4419             # P.112 Smartmatch Operator
4420             # in Chapter 3: Unary and Binary Operators
4421             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4422              
4423             # (and so on)
4424              
4425             elsif (/\G ((?>
4426              
4427             !~~ | !~ | != | ! |
4428             %= | % |
4429             &&= | && | &= | &\.= | &\. | & |
4430             -= | -> | - |
4431             :(?>\s*)= |
4432             : |
4433             <<>> |
4434             <<= | <=> | <= | < |
4435             == | => | =~ | = |
4436             >>= | >> | >= | > |
4437             \*\*= | \*\* | \*= | \* |
4438             \+= | \+ |
4439             \.\. | \.= | \. |
4440             \/\/= | \/\/ |
4441             \/= | \/ |
4442             \? |
4443             \\ |
4444             \^= | \^\.= | \^\. | \^ |
4445             \b x= |
4446             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4447             ~~ | ~\. | ~ |
4448             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4449             \b(?: print )\b |
4450              
4451 7         22 [,;\(\{\[]
  8829         17993  
4452              
4453             )) /oxgc) { $slash = 'm//'; return $1; }
4454 8829         41550  
  14981         33746  
4455             # other any character
4456             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4457              
4458 14981         90668 # system error
4459             else {
4460             die __FILE__, ": Oops, this shouldn't happen!\n";
4461             }
4462             }
4463              
4464 0     1786 0 0 # escape Greek string
4465 1786         4697 sub e_string {
4466             my($string) = @_;
4467 1786         2758 my $e_string = '';
4468              
4469             local $slash = 'm//';
4470              
4471             # P.1024 Appendix W.10 Multibyte Processing
4472             # of ISBN 1-56592-224-7 CJKV Information Processing
4473 1786         3145 # (and so on)
4474              
4475             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4476 1786 100 66     14519  
4477 1786 50       7772 # without { ... }
4478 1769         4464 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4479             if ($string !~ /<
4480             return $string;
4481             }
4482             }
4483 1769         6110  
4484 17 50       57 E_STRING_LOOP:
    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          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4485             while ($string !~ /\G \z/oxgc) {
4486             if (0) {
4487             }
4488 190         12730  
4489 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Egreek::PREMATCH()]}
4490 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4491             $e_string .= q{Egreek::PREMATCH()};
4492             $slash = 'div';
4493             }
4494              
4495 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Egreek::MATCH()]}
4496 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4497             $e_string .= q{Egreek::MATCH()};
4498             $slash = 'div';
4499             }
4500              
4501 0         0 # $', ${'} --> $', ${'}
4502 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4503             $e_string .= $1;
4504             $slash = 'div';
4505             }
4506              
4507 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Egreek::POSTMATCH()]}
4508 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4509             $e_string .= q{Egreek::POSTMATCH()};
4510             $slash = 'div';
4511             }
4512              
4513 0         0 # bareword
4514 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4515             $e_string .= $1;
4516             $slash = 'div';
4517             }
4518              
4519 0         0 # $0 --> $0
4520 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4521             $e_string .= $1;
4522             $slash = 'div';
4523 0         0 }
4524 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4525             $e_string .= $1;
4526             $slash = 'div';
4527             }
4528              
4529 0         0 # $$ --> $$
4530 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4531             $e_string .= $1;
4532             $slash = 'div';
4533             }
4534              
4535             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4536 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4537 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4538             $e_string .= e_capture($1);
4539             $slash = 'div';
4540 0         0 }
4541 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4542             $e_string .= e_capture($1);
4543             $slash = 'div';
4544             }
4545              
4546 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4547 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4548             $e_string .= e_capture($1.'->'.$2);
4549             $slash = 'div';
4550             }
4551              
4552 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4553 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4554             $e_string .= e_capture($1.'->'.$2);
4555             $slash = 'div';
4556             }
4557              
4558 0         0 # $$foo
4559 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4560             $e_string .= e_capture($1);
4561             $slash = 'div';
4562             }
4563              
4564 0         0 # ${ foo }
4565 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4566             $e_string .= '${' . $1 . '}';
4567             $slash = 'div';
4568             }
4569              
4570 0         0 # ${ ... }
4571 3         11 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4572             $e_string .= e_capture($1);
4573             $slash = 'div';
4574             }
4575              
4576             # variable or function
4577 3         15 # $ @ % & * $ #
4578 7         20 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) {
4579             $e_string .= $1;
4580             $slash = 'div';
4581             }
4582             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4583 7         29 # $ @ # \ ' " / ? ( ) [ ] < >
4584 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4585             $e_string .= $1;
4586             $slash = 'div';
4587             }
4588 0         0  
  0         0  
4589 0         0 # subroutines of package Egreek
  0         0  
4590 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4591 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4592 0         0 elsif ($string =~ /\G \b Greek::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4593 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4594 0         0 elsif ($string =~ /\G \b Greek::eval \b /oxgc) { $e_string .= 'eval Greek::escape'; $slash = 'm//'; }
  0         0  
4595 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4596 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Egreek::chop'; $slash = 'm//'; }
  0         0  
4597 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4598 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4599 0         0 elsif ($string =~ /\G \b Greek::index \b /oxgc) { $e_string .= 'Greek::index'; $slash = 'm//'; }
  0         0  
4600 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Egreek::index'; $slash = 'm//'; }
  0         0  
4601 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4602 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4603 0         0 elsif ($string =~ /\G \b Greek::rindex \b /oxgc) { $e_string .= 'Greek::rindex'; $slash = 'm//'; }
  0         0  
4604 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Egreek::rindex'; $slash = 'm//'; }
  0         0  
4605 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egreek::lc'; $slash = 'm//'; }
  0         0  
4606 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egreek::lcfirst'; $slash = 'm//'; }
  0         0  
4607 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egreek::uc'; $slash = 'm//'; }
  0         0  
4608             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egreek::ucfirst'; $slash = 'm//'; }
4609             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egreek::fc'; $slash = 'm//'; }
4610 0         0  
  0         0  
4611 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4612 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4613 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  
4614 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  
4615 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  
4616 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  
4617             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4618 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  
4619 0         0  
  0         0  
4620 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4621 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  
4622 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  
4623 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  
4624 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  
4625             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4626             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4627 0         0  
  0         0  
4628 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4629 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4630 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4631             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4632 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4633 0         0  
  0         0  
4634 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4635 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4636 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egreek::chr'; $slash = 'm//'; }
  0         0  
4637 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4638 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4639 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egreek::glob'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Egreek::lc_'; $slash = 'm//'; }
  0         0  
4641 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Egreek::lcfirst_'; $slash = 'm//'; }
  0         0  
4642 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Egreek::uc_'; $slash = 'm//'; }
  0         0  
4643 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Egreek::ucfirst_'; $slash = 'm//'; }
  0         0  
4644             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Egreek::fc_'; $slash = 'm//'; }
4645 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4646 0         0  
  0         0  
4647 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4648 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4649 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Egreek::chr_'; $slash = 'm//'; }
  0         0  
4650 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4651 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4652 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Egreek::glob_'; $slash = 'm//'; }
  0         0  
4653             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4654             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4655 0         0 # split
4656             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4657 0         0 $slash = 'm//';
4658 0         0  
4659 0         0 my $e = '';
4660             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4661             $e .= $1;
4662             }
4663 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4664             # end of split
4665             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Egreek::split' . $e; }
4666 0         0  
  0         0  
4667             # split scalar value
4668             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Egreek::split' . $e . e_string($1); next E_STRING_LOOP; }
4669 0         0  
  0         0  
4670 0         0 # split literal space
  0         0  
4671 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Egreek::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Egreek::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Egreek::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4674 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Egreek::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Egreek::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Egreek::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4677 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Egreek::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4678 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Egreek::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4679 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Egreek::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4680 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Egreek::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4681 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Egreek::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4682 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Egreek::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4683             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Egreek::split' . $e . qq {' '}; next E_STRING_LOOP; }
4684             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Egreek::split' . $e . qq {" "}; next E_STRING_LOOP; }
4685              
4686 0 0       0 # split qq//
  0         0  
  0         0  
4687             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4688 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4689 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4690 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4691 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4692 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  
4693 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  
4694 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  
4695 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  
4696             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4697 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 * *
4698             }
4699             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4700             }
4701             }
4702              
4703 0 0       0 # split qr//
  0         0  
  0         0  
4704             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4705 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4706 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4707 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4708 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4709 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  
4710 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  
4711 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  
4712 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  
4713 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  
4714             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4715 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 * *
4716             }
4717             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4718             }
4719             }
4720              
4721 0 0       0 # split q//
  0         0  
  0         0  
4722             elsif ($string =~ /\G \b (q) \b /oxgc) {
4723 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4724 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4725 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4726 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4727 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  
4728 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  
4729 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  
4730 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  
4731             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4732 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 * *
4733             }
4734             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4735             }
4736             }
4737              
4738 0 0       0 # split m//
  0         0  
  0         0  
4739             elsif ($string =~ /\G \b (m) \b /oxgc) {
4740 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 # #
4741 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4742 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4743 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4744 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  
4745 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  
4746 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  
4747 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  
4748 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  
4749             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4750 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 * *
4751             }
4752             die __FILE__, ": Search pattern not terminated\n";
4753             }
4754             }
4755              
4756 0         0 # split ''
4757 0         0 elsif ($string =~ /\G (\') /oxgc) {
4758 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4759 0         0 while ($string !~ /\G \z/oxgc) {
4760 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4761 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4762             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4763 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4764             }
4765             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4766             }
4767              
4768 0         0 # split ""
4769 0         0 elsif ($string =~ /\G (\") /oxgc) {
4770 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4771 0         0 while ($string !~ /\G \z/oxgc) {
4772 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4773 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4774             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4775 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4776             }
4777             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4778             }
4779              
4780 0         0 # split //
4781 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4782 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4783 0         0 while ($string !~ /\G \z/oxgc) {
4784 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4785 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4786             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4787 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4788             }
4789             die __FILE__, ": Search pattern not terminated\n";
4790             }
4791             }
4792              
4793 0         0 # qq//
4794 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4795 0         0 my $ope = $1;
4796             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4797             $e_string .= e_qq($ope,$1,$3,$2);
4798 0         0 }
4799 0         0 else {
4800 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4801 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4802 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4803 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4804 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4805 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4806             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4807 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4808             }
4809             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4810             }
4811             }
4812              
4813 0         0 # qx//
4814 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4815 0         0 my $ope = $1;
4816             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4817             $e_string .= e_qq($ope,$1,$3,$2);
4818 0         0 }
4819 0         0 else {
4820 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4821 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4822 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4823 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4824 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4825 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4826 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4827             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4828 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4829             }
4830             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4831             }
4832             }
4833              
4834 0         0 # q//
4835 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4836 0         0 my $ope = $1;
4837             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4838             $e_string .= e_q($ope,$1,$3,$2);
4839 0         0 }
4840 0         0 else {
4841 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4842 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4843 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4844 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4845 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4846 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4847             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4848 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 * *
4849             }
4850             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4851             }
4852             }
4853 0         0  
4854             # ''
4855             elsif ($string =~ /\G (?
4856 0         0  
4857             # ""
4858             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4859 0         0  
4860             # ``
4861             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4862 0         0  
4863             # <<>> (a safer ARGV)
4864             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4865 0         0  
4866             # <<= <=> <= < operator
4867             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4868 0         0  
4869             #
4870             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4871              
4872 0         0 # --- glob
4873             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4874             $e_string .= 'Egreek::glob("' . $1 . '")';
4875             }
4876              
4877 0         0 # << (bit shift) --- not here document
4878 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4879             $slash = 'm//';
4880             $e_string .= $1;
4881             }
4882              
4883 0         0 # <<~'HEREDOC'
4884 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4885 0         0 $slash = 'm//';
4886             my $here_quote = $1;
4887             my $delimiter = $2;
4888 0 0       0  
4889 0         0 # get here document
4890 0         0 if ($here_script eq '') {
4891             $here_script = CORE::substr $_, pos $_;
4892 0 0       0 $here_script =~ s/.*?\n//oxm;
4893 0         0 }
4894 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4895 0         0 my $heredoc = $1;
4896 0         0 my $indent = $2;
4897 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4898             push @heredoc, $heredoc . qq{\n$delimiter\n};
4899             push @heredoc_delimiter, qq{\\s*$delimiter};
4900 0         0 }
4901             else {
4902 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4903             }
4904             $e_string .= qq{<<'$delimiter'};
4905             }
4906              
4907 0         0 # <<~\HEREDOC
4908 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4909 0         0 $slash = 'm//';
4910             my $here_quote = $1;
4911             my $delimiter = $2;
4912 0 0       0  
4913 0         0 # get here document
4914 0         0 if ($here_script eq '') {
4915             $here_script = CORE::substr $_, pos $_;
4916 0 0       0 $here_script =~ s/.*?\n//oxm;
4917 0         0 }
4918 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4919 0         0 my $heredoc = $1;
4920 0         0 my $indent = $2;
4921 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4922             push @heredoc, $heredoc . qq{\n$delimiter\n};
4923             push @heredoc_delimiter, qq{\\s*$delimiter};
4924 0         0 }
4925             else {
4926 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4927             }
4928             $e_string .= qq{<<\\$delimiter};
4929             }
4930              
4931 0         0 # <<~"HEREDOC"
4932 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4933 0         0 $slash = 'm//';
4934             my $here_quote = $1;
4935             my $delimiter = $2;
4936 0 0       0  
4937 0         0 # get here document
4938 0         0 if ($here_script eq '') {
4939             $here_script = CORE::substr $_, pos $_;
4940 0 0       0 $here_script =~ s/.*?\n//oxm;
4941 0         0 }
4942 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4943 0         0 my $heredoc = $1;
4944 0         0 my $indent = $2;
4945 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4946             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4947             push @heredoc_delimiter, qq{\\s*$delimiter};
4948 0         0 }
4949             else {
4950 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4951             }
4952             $e_string .= qq{<<"$delimiter"};
4953             }
4954              
4955 0         0 # <<~HEREDOC
4956 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4957 0         0 $slash = 'm//';
4958             my $here_quote = $1;
4959             my $delimiter = $2;
4960 0 0       0  
4961 0         0 # get here document
4962 0         0 if ($here_script eq '') {
4963             $here_script = CORE::substr $_, pos $_;
4964 0 0       0 $here_script =~ s/.*?\n//oxm;
4965 0         0 }
4966 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4967 0         0 my $heredoc = $1;
4968 0         0 my $indent = $2;
4969 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4970             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4971             push @heredoc_delimiter, qq{\\s*$delimiter};
4972 0         0 }
4973             else {
4974 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4975             }
4976             $e_string .= qq{<<$delimiter};
4977             }
4978              
4979 0         0 # <<~`HEREDOC`
4980 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4981 0         0 $slash = 'm//';
4982             my $here_quote = $1;
4983             my $delimiter = $2;
4984 0 0       0  
4985 0         0 # get here document
4986 0         0 if ($here_script eq '') {
4987             $here_script = CORE::substr $_, pos $_;
4988 0 0       0 $here_script =~ s/.*?\n//oxm;
4989 0         0 }
4990 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4991 0         0 my $heredoc = $1;
4992 0         0 my $indent = $2;
4993 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4994             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4995             push @heredoc_delimiter, qq{\\s*$delimiter};
4996 0         0 }
4997             else {
4998 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4999             }
5000             $e_string .= qq{<<`$delimiter`};
5001             }
5002              
5003 0         0 # <<'HEREDOC'
5004 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5005 0         0 $slash = 'm//';
5006             my $here_quote = $1;
5007             my $delimiter = $2;
5008 0 0       0  
5009 0         0 # get here document
5010 0         0 if ($here_script eq '') {
5011             $here_script = CORE::substr $_, pos $_;
5012 0 0       0 $here_script =~ s/.*?\n//oxm;
5013 0         0 }
5014 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5015             push @heredoc, $1 . qq{\n$delimiter\n};
5016             push @heredoc_delimiter, $delimiter;
5017 0         0 }
5018             else {
5019 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5020             }
5021             $e_string .= $here_quote;
5022             }
5023              
5024 0         0 # <<\HEREDOC
5025 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5026 0         0 $slash = 'm//';
5027             my $here_quote = $1;
5028             my $delimiter = $2;
5029 0 0       0  
5030 0         0 # get here document
5031 0         0 if ($here_script eq '') {
5032             $here_script = CORE::substr $_, pos $_;
5033 0 0       0 $here_script =~ s/.*?\n//oxm;
5034 0         0 }
5035 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5036             push @heredoc, $1 . qq{\n$delimiter\n};
5037             push @heredoc_delimiter, $delimiter;
5038 0         0 }
5039             else {
5040 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5041             }
5042             $e_string .= $here_quote;
5043             }
5044              
5045 0         0 # <<"HEREDOC"
5046 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5047 0         0 $slash = 'm//';
5048             my $here_quote = $1;
5049             my $delimiter = $2;
5050 0 0       0  
5051 0         0 # get here document
5052 0         0 if ($here_script eq '') {
5053             $here_script = CORE::substr $_, pos $_;
5054 0 0       0 $here_script =~ s/.*?\n//oxm;
5055 0         0 }
5056 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5057             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5058             push @heredoc_delimiter, $delimiter;
5059 0         0 }
5060             else {
5061 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5062             }
5063             $e_string .= $here_quote;
5064             }
5065              
5066 0         0 # <
5067 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5068 0         0 $slash = 'm//';
5069             my $here_quote = $1;
5070             my $delimiter = $2;
5071 0 0       0  
5072 0         0 # get here document
5073 0         0 if ($here_script eq '') {
5074             $here_script = CORE::substr $_, pos $_;
5075 0 0       0 $here_script =~ s/.*?\n//oxm;
5076 0         0 }
5077 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5078             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5079             push @heredoc_delimiter, $delimiter;
5080 0         0 }
5081             else {
5082 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5083             }
5084             $e_string .= $here_quote;
5085             }
5086              
5087 0         0 # <<`HEREDOC`
5088 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5089 0         0 $slash = 'm//';
5090             my $here_quote = $1;
5091             my $delimiter = $2;
5092 0 0       0  
5093 0         0 # get here document
5094 0         0 if ($here_script eq '') {
5095             $here_script = CORE::substr $_, pos $_;
5096 0 0       0 $here_script =~ s/.*?\n//oxm;
5097 0         0 }
5098 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5099             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5100             push @heredoc_delimiter, $delimiter;
5101 0         0 }
5102             else {
5103 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5104             }
5105             $e_string .= $here_quote;
5106             }
5107              
5108             # any operator before div
5109             elsif ($string =~ /\G (
5110             -- | \+\+ |
5111 0         0 [\)\}\]]
  18         32  
5112              
5113             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5114              
5115             # yada-yada or triple-dot operator
5116             elsif ($string =~ /\G (
5117 18         56 \.\.\.
  0         0  
5118              
5119             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5120              
5121             # any operator before m//
5122             elsif ($string =~ /\G ((?>
5123              
5124             !~~ | !~ | != | ! |
5125             %= | % |
5126             &&= | && | &= | &\.= | &\. | & |
5127             -= | -> | - |
5128             :(?>\s*)= |
5129             : |
5130             <<>> |
5131             <<= | <=> | <= | < |
5132             == | => | =~ | = |
5133             >>= | >> | >= | > |
5134             \*\*= | \*\* | \*= | \* |
5135             \+= | \+ |
5136             \.\. | \.= | \. |
5137             \/\/= | \/\/ |
5138             \/= | \/ |
5139             \? |
5140             \\ |
5141             \^= | \^\.= | \^\. | \^ |
5142             \b x= |
5143             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5144             ~~ | ~\. | ~ |
5145             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5146             \b(?: print )\b |
5147              
5148 0         0 [,;\(\{\[]
  31         72  
5149              
5150             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5151 31         113  
5152             # other any character
5153             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5154              
5155 131         361 # system error
5156             else {
5157             die __FILE__, ": Oops, this shouldn't happen!\n";
5158             }
5159 0         0 }
5160              
5161             return $e_string;
5162             }
5163              
5164             #
5165             # character class
5166 17     1919 0 71 #
5167             sub character_class {
5168 1919 100       4966 my($char,$modifier) = @_;
5169 1919 100       2942  
5170 52         93 if ($char eq '.') {
5171             if ($modifier =~ /s/) {
5172             return '${Egreek::dot_s}';
5173 17         38 }
5174             else {
5175             return '${Egreek::dot}';
5176             }
5177 35         69 }
5178             else {
5179             return Egreek::classic_character_class($char);
5180             }
5181             }
5182              
5183             #
5184             # escape capture ($1, $2, $3, ...)
5185             #
5186 1867     212 0 16362 sub e_capture {
5187              
5188             return join '', '${', $_[0], '}';
5189             }
5190              
5191             #
5192             # escape transliteration (tr/// or y///)
5193 212     3 0 895 #
5194 3         19 sub e_tr {
5195 3   50     6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5196             my $e_tr = '';
5197 3         6 $modifier ||= '';
5198              
5199             $slash = 'div';
5200 3         9  
5201             # quote character class 1
5202             $charclass = q_tr($charclass);
5203 3         6  
5204             # quote character class 2
5205             $charclass2 = q_tr($charclass2);
5206 3 50       5  
5207 3 0       8 # /b /B modifier
5208 0         0 if ($modifier =~ tr/bB//d) {
5209             if ($variable eq '') {
5210             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5211 0         0 }
5212             else {
5213             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5214             }
5215 0 100       0 }
5216 3         7 else {
5217             if ($variable eq '') {
5218             $e_tr = qq{Egreek::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5219 2         5 }
5220             else {
5221             $e_tr = qq{Egreek::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5222             }
5223             }
5224 1         4  
5225 3         4 # clear tr/// variable
5226             $tr_variable = '';
5227 3         4 $bind_operator = '';
5228              
5229             return $e_tr;
5230             }
5231              
5232             #
5233             # quote for escape transliteration (tr/// or y///)
5234 3     6 0 15 #
5235             sub q_tr {
5236             my($charclass) = @_;
5237 6 50       8  
    0          
    0          
    0          
    0          
    0          
5238 6         14 # quote character class
5239             if ($charclass !~ /'/oxms) {
5240             return e_q('', "'", "'", $charclass); # --> q' '
5241 6         9 }
5242             elsif ($charclass !~ /\//oxms) {
5243             return e_q('q', '/', '/', $charclass); # --> q/ /
5244 0         0 }
5245             elsif ($charclass !~ /\#/oxms) {
5246             return e_q('q', '#', '#', $charclass); # --> q# #
5247 0         0 }
5248             elsif ($charclass !~ /[\<\>]/oxms) {
5249             return e_q('q', '<', '>', $charclass); # --> q< >
5250 0         0 }
5251             elsif ($charclass !~ /[\(\)]/oxms) {
5252             return e_q('q', '(', ')', $charclass); # --> q( )
5253 0         0 }
5254             elsif ($charclass !~ /[\{\}]/oxms) {
5255             return e_q('q', '{', '}', $charclass); # --> q{ }
5256 0         0 }
5257 0 0       0 else {
5258 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5259             if ($charclass !~ /\Q$char\E/xms) {
5260             return e_q('q', $char, $char, $charclass);
5261             }
5262             }
5263 0         0 }
5264              
5265             return e_q('q', '{', '}', $charclass);
5266             }
5267              
5268             #
5269             # escape q string (q//, '')
5270 0     1264 0 0 #
5271             sub e_q {
5272 1264         3099 my($ope,$delimiter,$end_delimiter,$string) = @_;
5273              
5274 1264         3086 $slash = 'div';
5275              
5276             return join '', $ope, $delimiter, $string, $end_delimiter;
5277             }
5278              
5279             #
5280             # escape qq string (qq//, "", qx//, ``)
5281 1264     4043 0 8066 #
5282             sub e_qq {
5283 4043         9249 my($ope,$delimiter,$end_delimiter,$string) = @_;
5284              
5285 4043         5608 $slash = 'div';
5286 4043         5285  
5287             my $left_e = 0;
5288             my $right_e = 0;
5289 4043         4286  
5290             # split regexp
5291             my @char = $string =~ /\G((?>
5292             [^\\\$] |
5293             \\x\{ (?>[0-9A-Fa-f]+) \} |
5294             \\o\{ (?>[0-7]+) \} |
5295             \\N\{ (?>[^0-9\}][^\}]*) \} |
5296             \\ $q_char |
5297             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5298             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5299             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5300             \$ (?>\s* [0-9]+) |
5301             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5302             \$ \$ (?![\w\{]) |
5303             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5304             $q_char
5305 4043         173858 ))/oxmsg;
5306              
5307             for (my $i=0; $i <= $#char; $i++) {
5308 4043 50 33     13906  
    50 33        
    100          
    100          
    50          
5309 113357         395550 # "\L\u" --> "\u\L"
5310             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5311             @char[$i,$i+1] = @char[$i+1,$i];
5312             }
5313              
5314 0         0 # "\U\l" --> "\l\U"
5315             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5316             @char[$i,$i+1] = @char[$i+1,$i];
5317             }
5318              
5319 0         0 # octal escape sequence
5320             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5321             $char[$i] = Egreek::octchr($1);
5322             }
5323              
5324 1         5 # hexadecimal escape sequence
5325             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5326             $char[$i] = Egreek::hexchr($1);
5327             }
5328              
5329 1         10 # \N{CHARNAME} --> N{CHARNAME}
5330             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5331             $char[$i] = $1;
5332 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5333              
5334             if (0) {
5335             }
5336              
5337             # \F
5338             #
5339             # P.69 Table 2-6. Translation escapes
5340             # in Chapter 2: Bits and Pieces
5341             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5342             # (and so on)
5343 113357         990247  
5344 0 50       0 # \u \l \U \L \F \Q \E
5345 484         1038 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5346             if ($right_e < $left_e) {
5347             $char[$i] = '\\' . $char[$i];
5348             }
5349             }
5350             elsif ($char[$i] eq '\u') {
5351              
5352             # "STRING @{[ LIST EXPR ]} MORE STRING"
5353              
5354             # P.257 Other Tricks You Can Do with Hard References
5355             # in Chapter 8: References
5356             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5357              
5358             # P.353 Other Tricks You Can Do with Hard References
5359             # in Chapter 8: References
5360             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5361              
5362 0         0 # (and so on)
5363 0         0  
5364             $char[$i] = '@{[Egreek::ucfirst qq<';
5365             $left_e++;
5366 0         0 }
5367 0         0 elsif ($char[$i] eq '\l') {
5368             $char[$i] = '@{[Egreek::lcfirst qq<';
5369             $left_e++;
5370 0         0 }
5371 0         0 elsif ($char[$i] eq '\U') {
5372             $char[$i] = '@{[Egreek::uc qq<';
5373             $left_e++;
5374 0         0 }
5375 0         0 elsif ($char[$i] eq '\L') {
5376             $char[$i] = '@{[Egreek::lc qq<';
5377             $left_e++;
5378 0         0 }
5379 24         46 elsif ($char[$i] eq '\F') {
5380             $char[$i] = '@{[Egreek::fc qq<';
5381             $left_e++;
5382 24         42 }
5383 0         0 elsif ($char[$i] eq '\Q') {
5384             $char[$i] = '@{[CORE::quotemeta qq<';
5385             $left_e++;
5386 0 50       0 }
5387 24         51 elsif ($char[$i] eq '\E') {
5388 24         33 if ($right_e < $left_e) {
5389             $char[$i] = '>]}';
5390             $right_e++;
5391 24         50 }
5392             else {
5393             $char[$i] = '';
5394             }
5395 0         0 }
5396 0 0       0 elsif ($char[$i] eq '\Q') {
5397 0         0 while (1) {
5398             if (++$i > $#char) {
5399 0 0       0 last;
5400 0         0 }
5401             if ($char[$i] eq '\E') {
5402             last;
5403             }
5404             }
5405             }
5406             elsif ($char[$i] eq '\E') {
5407             }
5408              
5409             # $0 --> $0
5410             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5411             }
5412             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5413             }
5414              
5415             # $$ --> $$
5416             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5417             }
5418              
5419             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5420 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5421             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5422             $char[$i] = e_capture($1);
5423 205         404 }
5424             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5425             $char[$i] = e_capture($1);
5426             }
5427              
5428 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5429             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5430             $char[$i] = e_capture($1.'->'.$2);
5431             }
5432              
5433 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5434             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5435             $char[$i] = e_capture($1.'->'.$2);
5436             }
5437              
5438 0         0 # $$foo
5439             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5440             $char[$i] = e_capture($1);
5441             }
5442              
5443 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egreek::PREMATCH()
5444             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5445             $char[$i] = '@{[Egreek::PREMATCH()]}';
5446             }
5447              
5448 44         123 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egreek::MATCH()
5449             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5450             $char[$i] = '@{[Egreek::MATCH()]}';
5451             }
5452              
5453 45         122 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egreek::POSTMATCH()
5454             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5455             $char[$i] = '@{[Egreek::POSTMATCH()]}';
5456             }
5457              
5458             # ${ foo } --> ${ foo }
5459             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5460             }
5461              
5462 33         104 # ${ ... }
5463             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5464             $char[$i] = e_capture($1);
5465             }
5466             }
5467 0 50       0  
5468 4043         7841 # return string
5469             if ($left_e > $right_e) {
5470 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5471             }
5472             return join '', $ope, $delimiter, @char, $end_delimiter;
5473             }
5474              
5475             #
5476             # escape qw string (qw//)
5477 4043     16 0 34821 #
5478             sub e_qw {
5479 16         189 my($ope,$delimiter,$end_delimiter,$string) = @_;
5480              
5481             $slash = 'div';
5482 16         37  
  16         257  
5483 483 50       805 # choice again delimiter
    0          
    0          
    0          
    0          
5484 16         105 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5485             if (not $octet{$end_delimiter}) {
5486             return join '', $ope, $delimiter, $string, $end_delimiter;
5487 16         145 }
5488             elsif (not $octet{')'}) {
5489             return join '', $ope, '(', $string, ')';
5490 0         0 }
5491             elsif (not $octet{'}'}) {
5492             return join '', $ope, '{', $string, '}';
5493 0         0 }
5494             elsif (not $octet{']'}) {
5495             return join '', $ope, '[', $string, ']';
5496 0         0 }
5497             elsif (not $octet{'>'}) {
5498             return join '', $ope, '<', $string, '>';
5499 0         0 }
5500 0 0       0 else {
5501 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5502             if (not $octet{$char}) {
5503             return join '', $ope, $char, $string, $char;
5504             }
5505             }
5506             }
5507 0         0  
5508 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5509 0         0 my @string = CORE::split(/\s+/, $string);
5510 0         0 for my $string (@string) {
5511 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5512 0         0 for my $octet (@octet) {
5513             if ($octet =~ /\A (['\\]) \z/oxms) {
5514             $octet = '\\' . $1;
5515 0         0 }
5516             }
5517 0         0 $string = join '', @octet;
  0         0  
5518             }
5519             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5520             }
5521              
5522             #
5523             # escape here document (<<"HEREDOC", <
5524 0     93 0 0 #
5525             sub e_heredoc {
5526 93         258 my($string) = @_;
5527              
5528 93         259 $slash = 'm//';
5529              
5530 93         362 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5531 93         153  
5532             my $left_e = 0;
5533             my $right_e = 0;
5534 93         125  
5535             # split regexp
5536             my @char = $string =~ /\G((?>
5537             [^\\\$] |
5538             \\x\{ (?>[0-9A-Fa-f]+) \} |
5539             \\o\{ (?>[0-7]+) \} |
5540             \\N\{ (?>[^0-9\}][^\}]*) \} |
5541             \\ $q_char |
5542             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5543             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5544             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5545             \$ (?>\s* [0-9]+) |
5546             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5547             \$ \$ (?![\w\{]) |
5548             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5549             $q_char
5550 93         9190 ))/oxmsg;
5551              
5552             for (my $i=0; $i <= $#char; $i++) {
5553 93 50 33     409  
    50 33        
    100          
    100          
    50          
5554 3151         10417 # "\L\u" --> "\u\L"
5555             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5556             @char[$i,$i+1] = @char[$i+1,$i];
5557             }
5558              
5559 0         0 # "\U\l" --> "\l\U"
5560             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5561             @char[$i,$i+1] = @char[$i+1,$i];
5562             }
5563              
5564 0         0 # octal escape sequence
5565             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5566             $char[$i] = Egreek::octchr($1);
5567             }
5568              
5569 1         3 # hexadecimal escape sequence
5570             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5571             $char[$i] = Egreek::hexchr($1);
5572             }
5573              
5574 1         2 # \N{CHARNAME} --> N{CHARNAME}
5575             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5576             $char[$i] = $1;
5577 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5578              
5579             if (0) {
5580             }
5581 3151         48941  
5582 0 0       0 # \u \l \U \L \F \Q \E
5583 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5584             if ($right_e < $left_e) {
5585             $char[$i] = '\\' . $char[$i];
5586             }
5587 0         0 }
5588 0         0 elsif ($char[$i] eq '\u') {
5589             $char[$i] = '@{[Egreek::ucfirst qq<';
5590             $left_e++;
5591 0         0 }
5592 0         0 elsif ($char[$i] eq '\l') {
5593             $char[$i] = '@{[Egreek::lcfirst qq<';
5594             $left_e++;
5595 0         0 }
5596 0         0 elsif ($char[$i] eq '\U') {
5597             $char[$i] = '@{[Egreek::uc qq<';
5598             $left_e++;
5599 0         0 }
5600 0         0 elsif ($char[$i] eq '\L') {
5601             $char[$i] = '@{[Egreek::lc qq<';
5602             $left_e++;
5603 0         0 }
5604 0         0 elsif ($char[$i] eq '\F') {
5605             $char[$i] = '@{[Egreek::fc qq<';
5606             $left_e++;
5607 0         0 }
5608 0         0 elsif ($char[$i] eq '\Q') {
5609             $char[$i] = '@{[CORE::quotemeta qq<';
5610             $left_e++;
5611 0 0       0 }
5612 0         0 elsif ($char[$i] eq '\E') {
5613 0         0 if ($right_e < $left_e) {
5614             $char[$i] = '>]}';
5615             $right_e++;
5616 0         0 }
5617             else {
5618             $char[$i] = '';
5619             }
5620 0         0 }
5621 0 0       0 elsif ($char[$i] eq '\Q') {
5622 0         0 while (1) {
5623             if (++$i > $#char) {
5624 0 0       0 last;
5625 0         0 }
5626             if ($char[$i] eq '\E') {
5627             last;
5628             }
5629             }
5630             }
5631             elsif ($char[$i] eq '\E') {
5632             }
5633              
5634             # $0 --> $0
5635             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5636             }
5637             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5638             }
5639              
5640             # $$ --> $$
5641             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5642             }
5643              
5644             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5645 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5646             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5647             $char[$i] = e_capture($1);
5648 0         0 }
5649             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5650             $char[$i] = e_capture($1);
5651             }
5652              
5653 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5654             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5655             $char[$i] = e_capture($1.'->'.$2);
5656             }
5657              
5658 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5659             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5660             $char[$i] = e_capture($1.'->'.$2);
5661             }
5662              
5663 0         0 # $$foo
5664             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5665             $char[$i] = e_capture($1);
5666             }
5667              
5668 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egreek::PREMATCH()
5669             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5670             $char[$i] = '@{[Egreek::PREMATCH()]}';
5671             }
5672              
5673 8         53 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egreek::MATCH()
5674             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5675             $char[$i] = '@{[Egreek::MATCH()]}';
5676             }
5677              
5678 8         43 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egreek::POSTMATCH()
5679             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5680             $char[$i] = '@{[Egreek::POSTMATCH()]}';
5681             }
5682              
5683             # ${ foo } --> ${ foo }
5684             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5685             }
5686              
5687 6         44 # ${ ... }
5688             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5689             $char[$i] = e_capture($1);
5690             }
5691             }
5692 0 50       0  
5693 93         229 # return string
5694             if ($left_e > $right_e) {
5695 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5696             }
5697             return join '', @char;
5698             }
5699              
5700             #
5701             # escape regexp (m//, qr//)
5702 93     652 0 1978 #
5703 652   100     3072 sub e_qr {
5704             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5705 652         3706 $modifier ||= '';
5706 652 50       2244  
5707 652         2708 $modifier =~ tr/p//d;
5708 0         0 if ($modifier =~ /([adlu])/oxms) {
5709 0 0       0 my $line = 0;
5710 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5711 0         0 if ($filename ne __FILE__) {
5712             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5713             last;
5714 0         0 }
5715             }
5716             die qq{Unsupported modifier "$1" used at line $line.\n};
5717 0         0 }
5718              
5719             $slash = 'div';
5720 652 100       1072  
    100          
5721 652         2140 # literal null string pattern
5722 8         10 if ($string eq '') {
5723 8         13 $modifier =~ tr/bB//d;
5724             $modifier =~ tr/i//d;
5725             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5726             }
5727              
5728             # /b /B modifier
5729             elsif ($modifier =~ tr/bB//d) {
5730 8 50       40  
5731 2         9 # choice again delimiter
5732 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5733 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5734 0         0 my %octet = map {$_ => 1} @char;
5735 0         0 if (not $octet{')'}) {
5736             $delimiter = '(';
5737             $end_delimiter = ')';
5738 0         0 }
5739 0         0 elsif (not $octet{'}'}) {
5740             $delimiter = '{';
5741             $end_delimiter = '}';
5742 0         0 }
5743 0         0 elsif (not $octet{']'}) {
5744             $delimiter = '[';
5745             $end_delimiter = ']';
5746 0         0 }
5747 0         0 elsif (not $octet{'>'}) {
5748             $delimiter = '<';
5749             $end_delimiter = '>';
5750 0         0 }
5751 0 0       0 else {
5752 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5753 0         0 if (not $octet{$char}) {
5754 0         0 $delimiter = $char;
5755             $end_delimiter = $char;
5756             last;
5757             }
5758             }
5759             }
5760 0 50 33     0 }
5761 2         12  
5762             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5763             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5764 0         0 }
5765             else {
5766             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5767             }
5768 2 100       13 }
5769 642         6450  
5770             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5771             my $metachar = qr/[\@\\|[\]{^]/oxms;
5772 642         2674  
5773             # split regexp
5774             my @char = $string =~ /\G((?>
5775             [^\\\$\@\[\(] |
5776             \\x (?>[0-9A-Fa-f]{1,2}) |
5777             \\ (?>[0-7]{2,3}) |
5778             \\c [\x40-\x5F] |
5779             \\x\{ (?>[0-9A-Fa-f]+) \} |
5780             \\o\{ (?>[0-7]+) \} |
5781             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5782             \\ $q_char |
5783             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5784             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5785             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5786             [\$\@] $qq_variable |
5787             \$ (?>\s* [0-9]+) |
5788             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5789             \$ \$ (?![\w\{]) |
5790             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5791             \[\^ |
5792             \[\: (?>[a-z]+) :\] |
5793             \[\:\^ (?>[a-z]+) :\] |
5794             \(\? |
5795             $q_char
5796             ))/oxmsg;
5797 642 50       83530  
5798 642         2856 # choice again delimiter
  0         0  
5799 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5800 0         0 my %octet = map {$_ => 1} @char;
5801 0         0 if (not $octet{')'}) {
5802             $delimiter = '(';
5803             $end_delimiter = ')';
5804 0         0 }
5805 0         0 elsif (not $octet{'}'}) {
5806             $delimiter = '{';
5807             $end_delimiter = '}';
5808 0         0 }
5809 0         0 elsif (not $octet{']'}) {
5810             $delimiter = '[';
5811             $end_delimiter = ']';
5812 0         0 }
5813 0         0 elsif (not $octet{'>'}) {
5814             $delimiter = '<';
5815             $end_delimiter = '>';
5816 0         0 }
5817 0 0       0 else {
5818 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5819 0         0 if (not $octet{$char}) {
5820 0         0 $delimiter = $char;
5821             $end_delimiter = $char;
5822             last;
5823             }
5824             }
5825             }
5826 0         0 }
5827 642         1054  
5828 642         835 my $left_e = 0;
5829             my $right_e = 0;
5830             for (my $i=0; $i <= $#char; $i++) {
5831 642 50 66     1703  
    50 66        
    100          
    100          
    100          
    100          
5832 1872         10455 # "\L\u" --> "\u\L"
5833             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5834             @char[$i,$i+1] = @char[$i+1,$i];
5835             }
5836              
5837 0         0 # "\U\l" --> "\l\U"
5838             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5839             @char[$i,$i+1] = @char[$i+1,$i];
5840             }
5841              
5842 0         0 # octal escape sequence
5843             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5844             $char[$i] = Egreek::octchr($1);
5845             }
5846              
5847 1         3 # hexadecimal escape sequence
5848             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5849             $char[$i] = Egreek::hexchr($1);
5850             }
5851              
5852             # \b{...} --> b\{...}
5853             # \B{...} --> B\{...}
5854             # \N{CHARNAME} --> N\{CHARNAME}
5855             # \p{PROPERTY} --> p\{PROPERTY}
5856 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5857             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5858             $char[$i] = $1 . '\\' . $2;
5859             }
5860              
5861 6         26 # \p, \P, \X --> p, P, X
5862             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5863             $char[$i] = $1;
5864 4 100 100     11 }
    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          
5865              
5866             if (0) {
5867             }
5868 1872         6940  
5869 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5870 6         82 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5871             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)) {
5872             $char[$i] .= join '', splice @char, $i+1, 3;
5873 0         0 }
5874             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)) {
5875             $char[$i] .= join '', splice @char, $i+1, 2;
5876 0         0 }
5877             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)) {
5878             $char[$i] .= join '', splice @char, $i+1, 1;
5879             }
5880             }
5881              
5882 0         0 # open character class [...]
5883             elsif ($char[$i] eq '[') {
5884             my $left = $i;
5885              
5886             # [] make die "Unmatched [] in regexp ...\n"
5887 328 100       457 # (and so on)
5888 328         759  
5889             if ($char[$i+1] eq ']') {
5890             $i++;
5891 3         5 }
5892 328 50       427  
5893 1379         3264 while (1) {
5894             if (++$i > $#char) {
5895 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5896 1379         2402 }
5897             if ($char[$i] eq ']') {
5898             my $right = $i;
5899 328 100       414  
5900 328         1974 # [...]
  30         69  
5901             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5902             splice @char, $left, $right-$left+1, sprintf(q{@{[Egreek::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5903 90         127 }
5904             else {
5905             splice @char, $left, $right-$left+1, Egreek::charlist_qr(@char[$left+1..$right-1], $modifier);
5906 298         1309 }
5907 328         650  
5908             $i = $left;
5909             last;
5910             }
5911             }
5912             }
5913              
5914 328         823 # open character class [^...]
5915             elsif ($char[$i] eq '[^') {
5916             my $left = $i;
5917              
5918             # [^] make die "Unmatched [] in regexp ...\n"
5919 74 100       95 # (and so on)
5920 74         164  
5921             if ($char[$i+1] eq ']') {
5922             $i++;
5923 4         7 }
5924 74 50       80  
5925 272         375 while (1) {
5926             if (++$i > $#char) {
5927 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5928 272         466 }
5929             if ($char[$i] eq ']') {
5930             my $right = $i;
5931 74 100       110  
5932 74         366 # [^...]
  30         72  
5933             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5934             splice @char, $left, $right-$left+1, sprintf(q{@{[Egreek::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5935 90         145 }
5936             else {
5937             splice @char, $left, $right-$left+1, Egreek::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5938 44         201 }
5939 74         137  
5940             $i = $left;
5941             last;
5942             }
5943             }
5944             }
5945              
5946 74         198 # rewrite character class or escape character
5947             elsif (my $char = character_class($char[$i],$modifier)) {
5948             $char[$i] = $char;
5949             }
5950              
5951 139 50       334 # /i modifier
5952 20         32 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egreek::uc($char[$i]) ne Egreek::fc($char[$i]))) {
5953             if (CORE::length(Egreek::fc($char[$i])) == 1) {
5954             $char[$i] = '[' . Egreek::uc($char[$i]) . Egreek::fc($char[$i]) . ']';
5955 20         36 }
5956             else {
5957             $char[$i] = '(?:' . Egreek::uc($char[$i]) . '|' . Egreek::fc($char[$i]) . ')';
5958             }
5959             }
5960              
5961 0 50       0 # \u \l \U \L \F \Q \E
5962 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5963             if ($right_e < $left_e) {
5964             $char[$i] = '\\' . $char[$i];
5965             }
5966 0         0 }
5967 0         0 elsif ($char[$i] eq '\u') {
5968             $char[$i] = '@{[Egreek::ucfirst qq<';
5969             $left_e++;
5970 0         0 }
5971 0         0 elsif ($char[$i] eq '\l') {
5972             $char[$i] = '@{[Egreek::lcfirst qq<';
5973             $left_e++;
5974 0         0 }
5975 1         3 elsif ($char[$i] eq '\U') {
5976             $char[$i] = '@{[Egreek::uc qq<';
5977             $left_e++;
5978 1         2 }
5979 1         2 elsif ($char[$i] eq '\L') {
5980             $char[$i] = '@{[Egreek::lc qq<';
5981             $left_e++;
5982 1         2 }
5983 18         42 elsif ($char[$i] eq '\F') {
5984             $char[$i] = '@{[Egreek::fc qq<';
5985             $left_e++;
5986 18         39 }
5987 1         2 elsif ($char[$i] eq '\Q') {
5988             $char[$i] = '@{[CORE::quotemeta qq<';
5989             $left_e++;
5990 1 50       3 }
5991 21         44 elsif ($char[$i] eq '\E') {
5992 21         28 if ($right_e < $left_e) {
5993             $char[$i] = '>]}';
5994             $right_e++;
5995 21         52 }
5996             else {
5997             $char[$i] = '';
5998             }
5999 0         0 }
6000 0 0       0 elsif ($char[$i] eq '\Q') {
6001 0         0 while (1) {
6002             if (++$i > $#char) {
6003 0 0       0 last;
6004 0         0 }
6005             if ($char[$i] eq '\E') {
6006             last;
6007             }
6008             }
6009             }
6010             elsif ($char[$i] eq '\E') {
6011             }
6012              
6013 0 0       0 # $0 --> $0
6014 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6015             if ($ignorecase) {
6016             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6017             }
6018 0 0       0 }
6019 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6020             if ($ignorecase) {
6021             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6022             }
6023             }
6024              
6025             # $$ --> $$
6026             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6027             }
6028              
6029             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6030 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6031 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6032 0         0 $char[$i] = e_capture($1);
6033             if ($ignorecase) {
6034             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6035             }
6036 0         0 }
6037 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6038 0         0 $char[$i] = e_capture($1);
6039             if ($ignorecase) {
6040             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6041             }
6042             }
6043              
6044 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6045 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6046 0         0 $char[$i] = e_capture($1.'->'.$2);
6047             if ($ignorecase) {
6048             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6049             }
6050             }
6051              
6052 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6053 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6054 0         0 $char[$i] = e_capture($1.'->'.$2);
6055             if ($ignorecase) {
6056             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6057             }
6058             }
6059              
6060 0         0 # $$foo
6061 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6062 0         0 $char[$i] = e_capture($1);
6063             if ($ignorecase) {
6064             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6065             }
6066             }
6067              
6068 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egreek::PREMATCH()
6069 8         21 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6070             if ($ignorecase) {
6071             $char[$i] = '@{[Egreek::ignorecase(Egreek::PREMATCH())]}';
6072 0         0 }
6073             else {
6074             $char[$i] = '@{[Egreek::PREMATCH()]}';
6075             }
6076             }
6077              
6078 8 50       25 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egreek::MATCH()
6079 8         21 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6080             if ($ignorecase) {
6081             $char[$i] = '@{[Egreek::ignorecase(Egreek::MATCH())]}';
6082 0         0 }
6083             else {
6084             $char[$i] = '@{[Egreek::MATCH()]}';
6085             }
6086             }
6087              
6088 8 50       21 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egreek::POSTMATCH()
6089 6         22 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6090             if ($ignorecase) {
6091             $char[$i] = '@{[Egreek::ignorecase(Egreek::POSTMATCH())]}';
6092 0         0 }
6093             else {
6094             $char[$i] = '@{[Egreek::POSTMATCH()]}';
6095             }
6096             }
6097              
6098 6 0       20 # ${ foo }
6099 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6100             if ($ignorecase) {
6101             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6102             }
6103             }
6104              
6105 0         0 # ${ ... }
6106 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6107 0         0 $char[$i] = e_capture($1);
6108             if ($ignorecase) {
6109             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6110             }
6111             }
6112              
6113 0         0 # $scalar or @array
6114 21 100       60 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6115 21         125 $char[$i] = e_string($char[$i]);
6116             if ($ignorecase) {
6117             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6118             }
6119             }
6120              
6121 11 100 33     67 # quote character before ? + * {
    50          
6122             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6123             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6124 138         1216 }
6125 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6126 0         0 my $char = $char[$i-1];
6127             if ($char[$i] eq '{') {
6128             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6129 0         0 }
6130             else {
6131             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6132             }
6133 0         0 }
6134             else {
6135             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6136             }
6137             }
6138             }
6139 127         496  
6140 642 50       1186 # make regexp string
6141 642 0 0     1741 $modifier =~ tr/i//d;
6142 0         0 if ($left_e > $right_e) {
6143             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6144             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6145 0         0 }
6146             else {
6147             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6148 0 50 33     0 }
6149 642         3626 }
6150             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6151             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6152 0         0 }
6153             else {
6154             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6155             }
6156             }
6157              
6158             #
6159             # double quote stuff
6160 642     180 0 6886 #
6161             sub qq_stuff {
6162             my($delimiter,$end_delimiter,$stuff) = @_;
6163 180 100       248  
6164 180         351 # scalar variable or array variable
6165             if ($stuff =~ /\A [\$\@] /oxms) {
6166             return $stuff;
6167             }
6168 100         332  
  80         166  
6169 80         206 # quote by delimiter
6170 80 50       185 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6171 80 50       131 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6172 80 50       118 next if $char eq $delimiter;
6173 80         137 next if $char eq $end_delimiter;
6174             if (not $octet{$char}) {
6175             return join '', 'qq', $char, $stuff, $char;
6176 80         286 }
6177             }
6178             return join '', 'qq', '<', $stuff, '>';
6179             }
6180              
6181             #
6182             # escape regexp (m'', qr'', and m''b, qr''b)
6183 0     10 0 0 #
6184 10   50     45 sub e_qr_q {
6185             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6186 10         42 $modifier ||= '';
6187 10 50       15  
6188 10         20 $modifier =~ tr/p//d;
6189 0         0 if ($modifier =~ /([adlu])/oxms) {
6190 0 0       0 my $line = 0;
6191 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6192 0         0 if ($filename ne __FILE__) {
6193             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6194             last;
6195 0         0 }
6196             }
6197             die qq{Unsupported modifier "$1" used at line $line.\n};
6198 0         0 }
6199              
6200             $slash = 'div';
6201 10 100       13  
    50          
6202 10         25 # literal null string pattern
6203 8         11 if ($string eq '') {
6204 8         8 $modifier =~ tr/bB//d;
6205             $modifier =~ tr/i//d;
6206             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6207             }
6208              
6209 8         37 # with /b /B modifier
6210             elsif ($modifier =~ tr/bB//d) {
6211             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6212             }
6213              
6214 0         0 # without /b /B modifier
6215             else {
6216             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6217             }
6218             }
6219              
6220             #
6221             # escape regexp (m'', qr'')
6222 2     2 0 8 #
6223             sub e_qr_qt {
6224 2 50       8 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6225              
6226             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6227 2         6  
6228             # split regexp
6229             my @char = $string =~ /\G((?>
6230             [^\\\[\$\@\/] |
6231             [\x00-\xFF] |
6232             \[\^ |
6233             \[\: (?>[a-z]+) \:\] |
6234             \[\:\^ (?>[a-z]+) \:\] |
6235             [\$\@\/] |
6236             \\ (?:$q_char) |
6237             (?:$q_char)
6238             ))/oxmsg;
6239 2         65  
6240 2 50 33     9 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6241             for (my $i=0; $i <= $#char; $i++) {
6242             if (0) {
6243             }
6244 2         16  
6245 0         0 # open character class [...]
6246 0 0       0 elsif ($char[$i] eq '[') {
6247 0         0 my $left = $i;
6248             if ($char[$i+1] eq ']') {
6249 0         0 $i++;
6250 0 0       0 }
6251 0         0 while (1) {
6252             if (++$i > $#char) {
6253 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6254 0         0 }
6255             if ($char[$i] eq ']') {
6256             my $right = $i;
6257 0         0  
6258             # [...]
6259 0         0 splice @char, $left, $right-$left+1, Egreek::charlist_qr(@char[$left+1..$right-1], $modifier);
6260 0         0  
6261             $i = $left;
6262             last;
6263             }
6264             }
6265             }
6266              
6267 0         0 # open character class [^...]
6268 0 0       0 elsif ($char[$i] eq '[^') {
6269 0         0 my $left = $i;
6270             if ($char[$i+1] eq ']') {
6271 0         0 $i++;
6272 0 0       0 }
6273 0         0 while (1) {
6274             if (++$i > $#char) {
6275 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6276 0         0 }
6277             if ($char[$i] eq ']') {
6278             my $right = $i;
6279 0         0  
6280             # [^...]
6281 0         0 splice @char, $left, $right-$left+1, Egreek::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6282 0         0  
6283             $i = $left;
6284             last;
6285             }
6286             }
6287             }
6288              
6289 0         0 # escape $ @ / and \
6290             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6291             $char[$i] = '\\' . $char[$i];
6292             }
6293              
6294 0         0 # rewrite character class or escape character
6295             elsif (my $char = character_class($char[$i],$modifier)) {
6296             $char[$i] = $char;
6297             }
6298              
6299 0 0       0 # /i modifier
6300 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egreek::uc($char[$i]) ne Egreek::fc($char[$i]))) {
6301             if (CORE::length(Egreek::fc($char[$i])) == 1) {
6302             $char[$i] = '[' . Egreek::uc($char[$i]) . Egreek::fc($char[$i]) . ']';
6303 0         0 }
6304             else {
6305             $char[$i] = '(?:' . Egreek::uc($char[$i]) . '|' . Egreek::fc($char[$i]) . ')';
6306             }
6307             }
6308              
6309 0 0       0 # quote character before ? + * {
6310             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6311             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6312 0         0 }
6313             else {
6314             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6315             }
6316             }
6317 0         0 }
6318 2         5  
6319             $delimiter = '/';
6320 2         3 $end_delimiter = '/';
6321 2         3  
6322             $modifier =~ tr/i//d;
6323             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6324             }
6325              
6326             #
6327             # escape regexp (m''b, qr''b)
6328 2     0 0 16 #
6329             sub e_qr_qb {
6330             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6331 0         0  
6332             # split regexp
6333             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6334 0         0  
6335 0 0       0 # unescape character
    0          
6336             for (my $i=0; $i <= $#char; $i++) {
6337             if (0) {
6338             }
6339 0         0  
6340             # remain \\
6341             elsif ($char[$i] eq '\\\\') {
6342             }
6343              
6344 0         0 # escape $ @ / and \
6345             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6346             $char[$i] = '\\' . $char[$i];
6347             }
6348 0         0 }
6349 0         0  
6350 0         0 $delimiter = '/';
6351             $end_delimiter = '/';
6352             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6353             }
6354              
6355             #
6356             # escape regexp (s/here//)
6357 0     76 0 0 #
6358 76   100     361 sub e_s1 {
6359             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6360 76         342 $modifier ||= '';
6361 76 50       124  
6362 76         550 $modifier =~ tr/p//d;
6363 0         0 if ($modifier =~ /([adlu])/oxms) {
6364 0 0       0 my $line = 0;
6365 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6366 0         0 if ($filename ne __FILE__) {
6367             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6368             last;
6369 0         0 }
6370             }
6371             die qq{Unsupported modifier "$1" used at line $line.\n};
6372 0         0 }
6373              
6374             $slash = 'div';
6375 76 100       220  
    50          
6376 76         315 # literal null string pattern
6377 8         9 if ($string eq '') {
6378 8         10 $modifier =~ tr/bB//d;
6379             $modifier =~ tr/i//d;
6380             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6381             }
6382              
6383             # /b /B modifier
6384             elsif ($modifier =~ tr/bB//d) {
6385 8 0       48  
6386 0         0 # choice again delimiter
6387 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6388 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6389 0         0 my %octet = map {$_ => 1} @char;
6390 0         0 if (not $octet{')'}) {
6391             $delimiter = '(';
6392             $end_delimiter = ')';
6393 0         0 }
6394 0         0 elsif (not $octet{'}'}) {
6395             $delimiter = '{';
6396             $end_delimiter = '}';
6397 0         0 }
6398 0         0 elsif (not $octet{']'}) {
6399             $delimiter = '[';
6400             $end_delimiter = ']';
6401 0         0 }
6402 0         0 elsif (not $octet{'>'}) {
6403             $delimiter = '<';
6404             $end_delimiter = '>';
6405 0         0 }
6406 0 0       0 else {
6407 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6408 0         0 if (not $octet{$char}) {
6409 0         0 $delimiter = $char;
6410             $end_delimiter = $char;
6411             last;
6412             }
6413             }
6414             }
6415 0         0 }
6416 0         0  
6417             my $prematch = '';
6418             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6419 0 100       0 }
6420 68         208  
6421             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6422             my $metachar = qr/[\@\\|[\]{^]/oxms;
6423 68         277  
6424             # split regexp
6425             my @char = $string =~ /\G((?>
6426             [^\\\$\@\[\(] |
6427             \\ (?>[1-9][0-9]*) |
6428             \\g (?>\s*) (?>[1-9][0-9]*) |
6429             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6430             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6431             \\x (?>[0-9A-Fa-f]{1,2}) |
6432             \\ (?>[0-7]{2,3}) |
6433             \\c [\x40-\x5F] |
6434             \\x\{ (?>[0-9A-Fa-f]+) \} |
6435             \\o\{ (?>[0-7]+) \} |
6436             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6437             \\ $q_char |
6438             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6439             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6440             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6441             [\$\@] $qq_variable |
6442             \$ (?>\s* [0-9]+) |
6443             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6444             \$ \$ (?![\w\{]) |
6445             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6446             \[\^ |
6447             \[\: (?>[a-z]+) :\] |
6448             \[\:\^ (?>[a-z]+) :\] |
6449             \(\? |
6450             $q_char
6451             ))/oxmsg;
6452 68 50       18161  
6453 68         553 # choice again delimiter
  0         0  
6454 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6455 0         0 my %octet = map {$_ => 1} @char;
6456 0         0 if (not $octet{')'}) {
6457             $delimiter = '(';
6458             $end_delimiter = ')';
6459 0         0 }
6460 0         0 elsif (not $octet{'}'}) {
6461             $delimiter = '{';
6462             $end_delimiter = '}';
6463 0         0 }
6464 0         0 elsif (not $octet{']'}) {
6465             $delimiter = '[';
6466             $end_delimiter = ']';
6467 0         0 }
6468 0         0 elsif (not $octet{'>'}) {
6469             $delimiter = '<';
6470             $end_delimiter = '>';
6471 0         0 }
6472 0 0       0 else {
6473 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6474 0         0 if (not $octet{$char}) {
6475 0         0 $delimiter = $char;
6476             $end_delimiter = $char;
6477             last;
6478             }
6479             }
6480             }
6481             }
6482 0         0  
  68         162  
6483             # count '('
6484 253         436 my $parens = grep { $_ eq '(' } @char;
6485 68         112  
6486 68         103 my $left_e = 0;
6487             my $right_e = 0;
6488             for (my $i=0; $i <= $#char; $i++) {
6489 68 50 33     217  
    50 33        
    100          
    100          
    50          
    50          
6490 195         1160 # "\L\u" --> "\u\L"
6491             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6492             @char[$i,$i+1] = @char[$i+1,$i];
6493             }
6494              
6495 0         0 # "\U\l" --> "\l\U"
6496             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6497             @char[$i,$i+1] = @char[$i+1,$i];
6498             }
6499              
6500 0         0 # octal escape sequence
6501             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6502             $char[$i] = Egreek::octchr($1);
6503             }
6504              
6505 1         3 # hexadecimal escape sequence
6506             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6507             $char[$i] = Egreek::hexchr($1);
6508             }
6509              
6510             # \b{...} --> b\{...}
6511             # \B{...} --> B\{...}
6512             # \N{CHARNAME} --> N\{CHARNAME}
6513             # \p{PROPERTY} --> p\{PROPERTY}
6514 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6515             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6516             $char[$i] = $1 . '\\' . $2;
6517             }
6518              
6519 0         0 # \p, \P, \X --> p, P, X
6520             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6521             $char[$i] = $1;
6522 0 50 66     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          
6523              
6524             if (0) {
6525             }
6526 195         710  
6527 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6528 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6529             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)) {
6530             $char[$i] .= join '', splice @char, $i+1, 3;
6531 0         0 }
6532             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)) {
6533             $char[$i] .= join '', splice @char, $i+1, 2;
6534 0         0 }
6535             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)) {
6536             $char[$i] .= join '', splice @char, $i+1, 1;
6537             }
6538             }
6539              
6540 0         0 # open character class [...]
6541 13 50       20 elsif ($char[$i] eq '[') {
6542 13         41 my $left = $i;
6543             if ($char[$i+1] eq ']') {
6544 0         0 $i++;
6545 13 50       17 }
6546 58         144 while (1) {
6547             if (++$i > $#char) {
6548 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6549 58         131 }
6550             if ($char[$i] eq ']') {
6551             my $right = $i;
6552 13 50       21  
6553 13         74 # [...]
  0         0  
6554             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6555             splice @char, $left, $right-$left+1, sprintf(q{@{[Egreek::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6556 0         0 }
6557             else {
6558             splice @char, $left, $right-$left+1, Egreek::charlist_qr(@char[$left+1..$right-1], $modifier);
6559 13         62 }
6560 13         24  
6561             $i = $left;
6562             last;
6563             }
6564             }
6565             }
6566              
6567 13         34 # open character class [^...]
6568 0 0       0 elsif ($char[$i] eq '[^') {
6569 0         0 my $left = $i;
6570             if ($char[$i+1] eq ']') {
6571 0         0 $i++;
6572 0 0       0 }
6573 0         0 while (1) {
6574             if (++$i > $#char) {
6575 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6576 0         0 }
6577             if ($char[$i] eq ']') {
6578             my $right = $i;
6579 0 0       0  
6580 0         0 # [^...]
  0         0  
6581             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6582             splice @char, $left, $right-$left+1, sprintf(q{@{[Egreek::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6583 0         0 }
6584             else {
6585             splice @char, $left, $right-$left+1, Egreek::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6586 0         0 }
6587 0         0  
6588             $i = $left;
6589             last;
6590             }
6591             }
6592             }
6593              
6594 0         0 # rewrite character class or escape character
6595             elsif (my $char = character_class($char[$i],$modifier)) {
6596             $char[$i] = $char;
6597             }
6598              
6599 7 50       17 # /i modifier
6600 3         12 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egreek::uc($char[$i]) ne Egreek::fc($char[$i]))) {
6601             if (CORE::length(Egreek::fc($char[$i])) == 1) {
6602             $char[$i] = '[' . Egreek::uc($char[$i]) . Egreek::fc($char[$i]) . ']';
6603 3         5 }
6604             else {
6605             $char[$i] = '(?:' . Egreek::uc($char[$i]) . '|' . Egreek::fc($char[$i]) . ')';
6606             }
6607             }
6608              
6609 0 0       0 # \u \l \U \L \F \Q \E
6610 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6611             if ($right_e < $left_e) {
6612             $char[$i] = '\\' . $char[$i];
6613             }
6614 0         0 }
6615 0         0 elsif ($char[$i] eq '\u') {
6616             $char[$i] = '@{[Egreek::ucfirst qq<';
6617             $left_e++;
6618 0         0 }
6619 0         0 elsif ($char[$i] eq '\l') {
6620             $char[$i] = '@{[Egreek::lcfirst qq<';
6621             $left_e++;
6622 0         0 }
6623 0         0 elsif ($char[$i] eq '\U') {
6624             $char[$i] = '@{[Egreek::uc qq<';
6625             $left_e++;
6626 0         0 }
6627 0         0 elsif ($char[$i] eq '\L') {
6628             $char[$i] = '@{[Egreek::lc qq<';
6629             $left_e++;
6630 0         0 }
6631 0         0 elsif ($char[$i] eq '\F') {
6632             $char[$i] = '@{[Egreek::fc qq<';
6633             $left_e++;
6634 0         0 }
6635 0         0 elsif ($char[$i] eq '\Q') {
6636             $char[$i] = '@{[CORE::quotemeta qq<';
6637             $left_e++;
6638 0 0       0 }
6639 0         0 elsif ($char[$i] eq '\E') {
6640 0         0 if ($right_e < $left_e) {
6641             $char[$i] = '>]}';
6642             $right_e++;
6643 0         0 }
6644             else {
6645             $char[$i] = '';
6646             }
6647 0         0 }
6648 0 0       0 elsif ($char[$i] eq '\Q') {
6649 0         0 while (1) {
6650             if (++$i > $#char) {
6651 0 0       0 last;
6652 0         0 }
6653             if ($char[$i] eq '\E') {
6654             last;
6655             }
6656             }
6657             }
6658             elsif ($char[$i] eq '\E') {
6659             }
6660              
6661             # \0 --> \0
6662             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6663             }
6664              
6665             # \g{N}, \g{-N}
6666              
6667             # P.108 Using Simple Patterns
6668             # in Chapter 7: In the World of Regular Expressions
6669             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6670              
6671             # P.221 Capturing
6672             # in Chapter 5: Pattern Matching
6673             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6674              
6675             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6676             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6677             }
6678              
6679             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6680             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6681             }
6682              
6683             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6684             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6685             }
6686              
6687             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6688             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6689             }
6690              
6691 0 0       0 # $0 --> $0
6692 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6693             if ($ignorecase) {
6694             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6695             }
6696 0 0       0 }
6697 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6698             if ($ignorecase) {
6699             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6700             }
6701             }
6702              
6703             # $$ --> $$
6704             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6705             }
6706              
6707             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6708 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6709 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6710 0         0 $char[$i] = e_capture($1);
6711             if ($ignorecase) {
6712             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6713             }
6714 0         0 }
6715 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6716 0         0 $char[$i] = e_capture($1);
6717             if ($ignorecase) {
6718             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6719             }
6720             }
6721              
6722 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6723 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6724 0         0 $char[$i] = e_capture($1.'->'.$2);
6725             if ($ignorecase) {
6726             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6727             }
6728             }
6729              
6730 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6731 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6732 0         0 $char[$i] = e_capture($1.'->'.$2);
6733             if ($ignorecase) {
6734             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6735             }
6736             }
6737              
6738 0         0 # $$foo
6739 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6740 0         0 $char[$i] = e_capture($1);
6741             if ($ignorecase) {
6742             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6743             }
6744             }
6745              
6746 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egreek::PREMATCH()
6747 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6748             if ($ignorecase) {
6749             $char[$i] = '@{[Egreek::ignorecase(Egreek::PREMATCH())]}';
6750 0         0 }
6751             else {
6752             $char[$i] = '@{[Egreek::PREMATCH()]}';
6753             }
6754             }
6755              
6756 4 50       15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egreek::MATCH()
6757 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6758             if ($ignorecase) {
6759             $char[$i] = '@{[Egreek::ignorecase(Egreek::MATCH())]}';
6760 0         0 }
6761             else {
6762             $char[$i] = '@{[Egreek::MATCH()]}';
6763             }
6764             }
6765              
6766 4 50       13 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egreek::POSTMATCH()
6767 3         12 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6768             if ($ignorecase) {
6769             $char[$i] = '@{[Egreek::ignorecase(Egreek::POSTMATCH())]}';
6770 0         0 }
6771             else {
6772             $char[$i] = '@{[Egreek::POSTMATCH()]}';
6773             }
6774             }
6775              
6776 3 0       12 # ${ foo }
6777 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6778             if ($ignorecase) {
6779             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6780             }
6781             }
6782              
6783 0         0 # ${ ... }
6784 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6785 0         0 $char[$i] = e_capture($1);
6786             if ($ignorecase) {
6787             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6788             }
6789             }
6790              
6791 0         0 # $scalar or @array
6792 4 50       25 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6793 4         29 $char[$i] = e_string($char[$i]);
6794             if ($ignorecase) {
6795             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
6796             }
6797             }
6798              
6799 0 50       0 # quote character before ? + * {
6800             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6801             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6802 13         64 }
6803             else {
6804             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6805             }
6806             }
6807             }
6808 13         61  
6809 68         276 # make regexp string
6810 68 50       123 my $prematch = '';
6811 68         182 $modifier =~ tr/i//d;
6812             if ($left_e > $right_e) {
6813 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6814             }
6815             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6816             }
6817              
6818             #
6819             # escape regexp (s'here'' or s'here''b)
6820 68     21 0 947 #
6821 21   100     53 sub e_s1_q {
6822             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6823 21         69 $modifier ||= '';
6824 21 50       31  
6825 21         46 $modifier =~ tr/p//d;
6826 0         0 if ($modifier =~ /([adlu])/oxms) {
6827 0 0       0 my $line = 0;
6828 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6829 0         0 if ($filename ne __FILE__) {
6830             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6831             last;
6832 0         0 }
6833             }
6834             die qq{Unsupported modifier "$1" used at line $line.\n};
6835 0         0 }
6836              
6837             $slash = 'div';
6838 21 100       33  
    50          
6839 21         77 # literal null string pattern
6840 8         10 if ($string eq '') {
6841 8         10 $modifier =~ tr/bB//d;
6842             $modifier =~ tr/i//d;
6843             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6844             }
6845              
6846 8         55 # with /b /B modifier
6847             elsif ($modifier =~ tr/bB//d) {
6848             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6849             }
6850              
6851 0         0 # without /b /B modifier
6852             else {
6853             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6854             }
6855             }
6856              
6857             #
6858             # escape regexp (s'here'')
6859 13     13 0 34 #
6860             sub e_s1_qt {
6861 13 50       67 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6862              
6863             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6864 13         34  
6865             # split regexp
6866             my @char = $string =~ /\G((?>
6867             [^\\\[\$\@\/] |
6868             [\x00-\xFF] |
6869             \[\^ |
6870             \[\: (?>[a-z]+) \:\] |
6871             \[\:\^ (?>[a-z]+) \:\] |
6872             [\$\@\/] |
6873             \\ (?:$q_char) |
6874             (?:$q_char)
6875             ))/oxmsg;
6876 13         327  
6877 13 50 33     44 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6878             for (my $i=0; $i <= $#char; $i++) {
6879             if (0) {
6880             }
6881 25         133  
6882 0         0 # open character class [...]
6883 0 0       0 elsif ($char[$i] eq '[') {
6884 0         0 my $left = $i;
6885             if ($char[$i+1] eq ']') {
6886 0         0 $i++;
6887 0 0       0 }
6888 0         0 while (1) {
6889             if (++$i > $#char) {
6890 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6891 0         0 }
6892             if ($char[$i] eq ']') {
6893             my $right = $i;
6894 0         0  
6895             # [...]
6896 0         0 splice @char, $left, $right-$left+1, Egreek::charlist_qr(@char[$left+1..$right-1], $modifier);
6897 0         0  
6898             $i = $left;
6899             last;
6900             }
6901             }
6902             }
6903              
6904 0         0 # open character class [^...]
6905 0 0       0 elsif ($char[$i] eq '[^') {
6906 0         0 my $left = $i;
6907             if ($char[$i+1] eq ']') {
6908 0         0 $i++;
6909 0 0       0 }
6910 0         0 while (1) {
6911             if (++$i > $#char) {
6912 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6913 0         0 }
6914             if ($char[$i] eq ']') {
6915             my $right = $i;
6916 0         0  
6917             # [^...]
6918 0         0 splice @char, $left, $right-$left+1, Egreek::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6919 0         0  
6920             $i = $left;
6921             last;
6922             }
6923             }
6924             }
6925              
6926 0         0 # escape $ @ / and \
6927             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6928             $char[$i] = '\\' . $char[$i];
6929             }
6930              
6931 0         0 # rewrite character class or escape character
6932             elsif (my $char = character_class($char[$i],$modifier)) {
6933             $char[$i] = $char;
6934             }
6935              
6936 6 0       14 # /i modifier
6937 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egreek::uc($char[$i]) ne Egreek::fc($char[$i]))) {
6938             if (CORE::length(Egreek::fc($char[$i])) == 1) {
6939             $char[$i] = '[' . Egreek::uc($char[$i]) . Egreek::fc($char[$i]) . ']';
6940 0         0 }
6941             else {
6942             $char[$i] = '(?:' . Egreek::uc($char[$i]) . '|' . Egreek::fc($char[$i]) . ')';
6943             }
6944             }
6945              
6946 0 0       0 # quote character before ? + * {
6947             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6948             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6949 0         0 }
6950             else {
6951             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6952             }
6953             }
6954 0         0 }
6955 13         27  
6956 13         19 $modifier =~ tr/i//d;
6957 13         17 $delimiter = '/';
6958 13         60 $end_delimiter = '/';
6959             my $prematch = '';
6960             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6961             }
6962              
6963             #
6964             # escape regexp (s'here''b)
6965 13     0 0 110 #
6966             sub e_s1_qb {
6967             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6968 0         0  
6969             # split regexp
6970             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6971 0         0  
6972 0 0       0 # unescape character
    0          
6973             for (my $i=0; $i <= $#char; $i++) {
6974             if (0) {
6975             }
6976 0         0  
6977             # remain \\
6978             elsif ($char[$i] eq '\\\\') {
6979             }
6980              
6981 0         0 # escape $ @ / and \
6982             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6983             $char[$i] = '\\' . $char[$i];
6984             }
6985 0         0 }
6986 0         0  
6987 0         0 $delimiter = '/';
6988 0         0 $end_delimiter = '/';
6989             my $prematch = '';
6990             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6991             }
6992              
6993             #
6994             # escape regexp (s''here')
6995 0     16 0 0 #
6996             sub e_s2_q {
6997 16         35 my($ope,$delimiter,$end_delimiter,$string) = @_;
6998              
6999 16         25 $slash = 'div';
7000 16         97  
7001 16 100       45 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7002             for (my $i=0; $i <= $#char; $i++) {
7003             if (0) {
7004             }
7005 9         36  
7006             # not escape \\
7007             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7008             }
7009              
7010 0         0 # escape $ @ / and \
7011             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7012             $char[$i] = '\\' . $char[$i];
7013             }
7014 5         14 }
7015              
7016             return join '', $ope, $delimiter, @char, $end_delimiter;
7017             }
7018              
7019             #
7020             # escape regexp (s/here/and here/modifier)
7021 16     97 0 50 #
7022 97   100     837 sub e_sub {
7023             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7024 97         410 $modifier ||= '';
7025 97 50       187  
7026 97         280 $modifier =~ tr/p//d;
7027 0         0 if ($modifier =~ /([adlu])/oxms) {
7028 0 0       0 my $line = 0;
7029 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7030 0         0 if ($filename ne __FILE__) {
7031             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7032             last;
7033 0         0 }
7034             }
7035             die qq{Unsupported modifier "$1" used at line $line.\n};
7036 0 100       0 }
7037 97         279  
7038 36         268 if ($variable eq '') {
7039             $variable = '$_';
7040             $bind_operator = ' =~ ';
7041 36         48 }
7042              
7043             $slash = 'div';
7044              
7045             # P.128 Start of match (or end of previous match): \G
7046             # P.130 Advanced Use of \G with Perl
7047             # in Chapter 3: Overview of Regular Expression Features and Flavors
7048             # P.312 Iterative Matching: Scalar Context, with /g
7049             # in Chapter 7: Perl
7050             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7051              
7052             # P.181 Where You Left Off: The \G Assertion
7053             # in Chapter 5: Pattern Matching
7054             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7055              
7056             # P.220 Where You Left Off: The \G Assertion
7057             # in Chapter 5: Pattern Matching
7058 97         183 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7059 97         159  
7060             my $e_modifier = $modifier =~ tr/e//d;
7061 97         147 my $r_modifier = $modifier =~ tr/r//d;
7062 97 50       142  
7063 97         249 my $my = '';
7064 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7065 0         0 $my = $variable;
7066             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7067             $variable =~ s/ = .+ \z//oxms;
7068 0         0 }
7069 97         456  
7070             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7071             $variable_basename =~ s/ \s+ \z//oxms;
7072 97         237  
7073 97 100       147 # quote replacement string
7074 97         241 my $e_replacement = '';
7075 17         38 if ($e_modifier >= 1) {
7076             $e_replacement = e_qq('', '', '', $replacement);
7077             $e_modifier--;
7078 17 100       23 }
7079 80         230 else {
7080             if ($delimiter2 eq "'") {
7081             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7082 16         38 }
7083             else {
7084             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7085             }
7086 64         167 }
7087              
7088             my $sub = '';
7089 97 100       183  
7090 97 100       260 # with /r
7091             if ($r_modifier) {
7092             if (0) {
7093             }
7094 8         19  
7095 0 50       0 # s///gr without multibyte anchoring
7096             elsif ($modifier =~ /g/oxms) {
7097             $sub = sprintf(
7098             # 1 2 3 4 5
7099             q,
7100              
7101             $variable, # 1
7102             ($delimiter1 eq "'") ? # 2
7103             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7104             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7105             $s_matched, # 3
7106             $e_replacement, # 4
7107             '$Egreek::re_r=CORE::eval $Egreek::re_r; ' x $e_modifier, # 5
7108             );
7109             }
7110              
7111             # s///r
7112 4         15 else {
7113              
7114 4 50       7 my $prematch = q{$`};
7115              
7116             $sub = sprintf(
7117             # 1 2 3 4 5 6 7
7118             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Egreek::re_r=%s; %s"%s$Egreek::re_r$'" } : %s>,
7119              
7120             $variable, # 1
7121             ($delimiter1 eq "'") ? # 2
7122             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7123             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7124             $s_matched, # 3
7125             $e_replacement, # 4
7126             '$Egreek::re_r=CORE::eval $Egreek::re_r; ' x $e_modifier, # 5
7127             $prematch, # 6
7128             $variable, # 7
7129             );
7130             }
7131 4 50       12  
7132 8         24 # $var !~ s///r doesn't make sense
7133             if ($bind_operator =~ / !~ /oxms) {
7134             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7135             }
7136             }
7137              
7138 0 100       0 # without /r
7139             else {
7140             if (0) {
7141             }
7142 89         211  
7143 0 100       0 # s///g without multibyte anchoring
    100          
7144             elsif ($modifier =~ /g/oxms) {
7145             $sub = sprintf(
7146             # 1 2 3 4 5 6 7 8
7147             q,
7148              
7149             $variable, # 1
7150             ($delimiter1 eq "'") ? # 2
7151             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7152             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7153             $s_matched, # 3
7154             $e_replacement, # 4
7155             '$Egreek::re_r=CORE::eval $Egreek::re_r; ' x $e_modifier, # 5
7156             $variable, # 6
7157             $variable, # 7
7158             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7159             );
7160             }
7161              
7162             # s///
7163 22         96 else {
7164              
7165 67 100       104 my $prematch = q{$`};
    100          
7166              
7167             $sub = sprintf(
7168              
7169             ($bind_operator =~ / =~ /oxms) ?
7170              
7171             # 1 2 3 4 5 6 7 8
7172             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Egreek::re_r=%s; %s%s="%s$Egreek::re_r$'"; 1 } : undef> :
7173              
7174             # 1 2 3 4 5 6 7 8
7175             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Egreek::re_r=%s; %s%s="%s$Egreek::re_r$'"; undef }>,
7176              
7177             $variable, # 1
7178             $bind_operator, # 2
7179             ($delimiter1 eq "'") ? # 3
7180             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7181             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7182             $s_matched, # 4
7183             $e_replacement, # 5
7184             '$Egreek::re_r=CORE::eval $Egreek::re_r; ' x $e_modifier, # 6
7185             $variable, # 7
7186             $prematch, # 8
7187             );
7188             }
7189             }
7190 67 50       362  
7191 97         290 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7192             if ($my ne '') {
7193             $sub = "($my, $sub)[1]";
7194             }
7195 0         0  
7196 97         149 # clear s/// variable
7197             $sub_variable = '';
7198 97         184 $bind_operator = '';
7199              
7200             return $sub;
7201             }
7202              
7203             #
7204             # escape regexp of split qr//
7205 97     74 0 749 #
7206 74   100     391 sub e_split {
7207             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7208 74         352 $modifier ||= '';
7209 74 50       120  
7210 74         209 $modifier =~ tr/p//d;
7211 0         0 if ($modifier =~ /([adlu])/oxms) {
7212 0 0       0 my $line = 0;
7213 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7214 0         0 if ($filename ne __FILE__) {
7215             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7216             last;
7217 0         0 }
7218             }
7219             die qq{Unsupported modifier "$1" used at line $line.\n};
7220 0         0 }
7221              
7222             $slash = 'div';
7223 74 50       125  
7224 74         181 # /b /B modifier
7225             if ($modifier =~ tr/bB//d) {
7226             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7227 0 50       0 }
7228 74         202  
7229             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7230             my $metachar = qr/[\@\\|[\]{^]/oxms;
7231 74         341  
7232             # split regexp
7233             my @char = $string =~ /\G((?>
7234             [^\\\$\@\[\(] |
7235             \\x (?>[0-9A-Fa-f]{1,2}) |
7236             \\ (?>[0-7]{2,3}) |
7237             \\c [\x40-\x5F] |
7238             \\x\{ (?>[0-9A-Fa-f]+) \} |
7239             \\o\{ (?>[0-7]+) \} |
7240             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7241             \\ $q_char |
7242             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7243             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7244             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7245             [\$\@] $qq_variable |
7246             \$ (?>\s* [0-9]+) |
7247             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7248             \$ \$ (?![\w\{]) |
7249             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7250             \[\^ |
7251             \[\: (?>[a-z]+) :\] |
7252             \[\:\^ (?>[a-z]+) :\] |
7253             \(\? |
7254             $q_char
7255 74         10086 ))/oxmsg;
7256 74         243  
7257 74         110 my $left_e = 0;
7258             my $right_e = 0;
7259             for (my $i=0; $i <= $#char; $i++) {
7260 74 50 33     402  
    50 33        
    100          
    100          
    50          
    50          
7261 249         1301 # "\L\u" --> "\u\L"
7262             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7263             @char[$i,$i+1] = @char[$i+1,$i];
7264             }
7265              
7266 0         0 # "\U\l" --> "\l\U"
7267             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7268             @char[$i,$i+1] = @char[$i+1,$i];
7269             }
7270              
7271 0         0 # octal escape sequence
7272             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7273             $char[$i] = Egreek::octchr($1);
7274             }
7275              
7276 1         4 # hexadecimal escape sequence
7277             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7278             $char[$i] = Egreek::hexchr($1);
7279             }
7280              
7281             # \b{...} --> b\{...}
7282             # \B{...} --> B\{...}
7283             # \N{CHARNAME} --> N\{CHARNAME}
7284             # \p{PROPERTY} --> p\{PROPERTY}
7285 1         2 # \P{PROPERTY} --> P\{PROPERTY}
7286             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7287             $char[$i] = $1 . '\\' . $2;
7288             }
7289              
7290 0         0 # \p, \P, \X --> p, P, X
7291             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7292             $char[$i] = $1;
7293 0 50 100     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          
7294              
7295             if (0) {
7296             }
7297 249         800  
7298 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7299 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7300             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)) {
7301             $char[$i] .= join '', splice @char, $i+1, 3;
7302 0         0 }
7303             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)) {
7304             $char[$i] .= join '', splice @char, $i+1, 2;
7305 0         0 }
7306             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)) {
7307             $char[$i] .= join '', splice @char, $i+1, 1;
7308             }
7309             }
7310              
7311 0         0 # open character class [...]
7312 3 50       7 elsif ($char[$i] eq '[') {
7313 3         9 my $left = $i;
7314             if ($char[$i+1] eq ']') {
7315 0         0 $i++;
7316 3 50       4 }
7317 7         15 while (1) {
7318             if (++$i > $#char) {
7319 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7320 7         13 }
7321             if ($char[$i] eq ']') {
7322             my $right = $i;
7323 3 50       6  
7324 3         18 # [...]
  0         0  
7325             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7326             splice @char, $left, $right-$left+1, sprintf(q{@{[Egreek::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7327 0         0 }
7328             else {
7329             splice @char, $left, $right-$left+1, Egreek::charlist_qr(@char[$left+1..$right-1], $modifier);
7330 3         13 }
7331 3         6  
7332             $i = $left;
7333             last;
7334             }
7335             }
7336             }
7337              
7338 3         8 # open character class [^...]
7339 0 0       0 elsif ($char[$i] eq '[^') {
7340 0         0 my $left = $i;
7341             if ($char[$i+1] eq ']') {
7342 0         0 $i++;
7343 0 0       0 }
7344 0         0 while (1) {
7345             if (++$i > $#char) {
7346 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7347 0         0 }
7348             if ($char[$i] eq ']') {
7349             my $right = $i;
7350 0 0       0  
7351 0         0 # [^...]
  0         0  
7352             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7353             splice @char, $left, $right-$left+1, sprintf(q{@{[Egreek::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7354 0         0 }
7355             else {
7356             splice @char, $left, $right-$left+1, Egreek::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7357 0         0 }
7358 0         0  
7359             $i = $left;
7360             last;
7361             }
7362             }
7363             }
7364              
7365 0         0 # rewrite character class or escape character
7366             elsif (my $char = character_class($char[$i],$modifier)) {
7367             $char[$i] = $char;
7368             }
7369              
7370             # P.794 29.2.161. split
7371             # in Chapter 29: Functions
7372             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7373              
7374             # P.951 split
7375             # in Chapter 27: Functions
7376             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7377              
7378             # said "The //m modifier is assumed when you split on the pattern /^/",
7379             # but perl5.008 is not so. Therefore, this software adds //m.
7380             # (and so on)
7381              
7382 1         3 # split(m/^/) --> split(m/^/m)
7383             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7384             $modifier .= 'm';
7385             }
7386              
7387 7 0       23 # /i modifier
7388 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egreek::uc($char[$i]) ne Egreek::fc($char[$i]))) {
7389             if (CORE::length(Egreek::fc($char[$i])) == 1) {
7390             $char[$i] = '[' . Egreek::uc($char[$i]) . Egreek::fc($char[$i]) . ']';
7391 0         0 }
7392             else {
7393             $char[$i] = '(?:' . Egreek::uc($char[$i]) . '|' . Egreek::fc($char[$i]) . ')';
7394             }
7395             }
7396              
7397 0 0       0 # \u \l \U \L \F \Q \E
7398 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7399             if ($right_e < $left_e) {
7400             $char[$i] = '\\' . $char[$i];
7401             }
7402 0         0 }
7403 0         0 elsif ($char[$i] eq '\u') {
7404             $char[$i] = '@{[Egreek::ucfirst qq<';
7405             $left_e++;
7406 0         0 }
7407 0         0 elsif ($char[$i] eq '\l') {
7408             $char[$i] = '@{[Egreek::lcfirst qq<';
7409             $left_e++;
7410 0         0 }
7411 0         0 elsif ($char[$i] eq '\U') {
7412             $char[$i] = '@{[Egreek::uc qq<';
7413             $left_e++;
7414 0         0 }
7415 0         0 elsif ($char[$i] eq '\L') {
7416             $char[$i] = '@{[Egreek::lc qq<';
7417             $left_e++;
7418 0         0 }
7419 0         0 elsif ($char[$i] eq '\F') {
7420             $char[$i] = '@{[Egreek::fc qq<';
7421             $left_e++;
7422 0         0 }
7423 0         0 elsif ($char[$i] eq '\Q') {
7424             $char[$i] = '@{[CORE::quotemeta qq<';
7425             $left_e++;
7426 0 0       0 }
7427 0         0 elsif ($char[$i] eq '\E') {
7428 0         0 if ($right_e < $left_e) {
7429             $char[$i] = '>]}';
7430             $right_e++;
7431 0         0 }
7432             else {
7433             $char[$i] = '';
7434             }
7435 0         0 }
7436 0 0       0 elsif ($char[$i] eq '\Q') {
7437 0         0 while (1) {
7438             if (++$i > $#char) {
7439 0 0       0 last;
7440 0         0 }
7441             if ($char[$i] eq '\E') {
7442             last;
7443             }
7444             }
7445             }
7446             elsif ($char[$i] eq '\E') {
7447             }
7448              
7449 0 0       0 # $0 --> $0
7450 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7451             if ($ignorecase) {
7452             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7453             }
7454 0 0       0 }
7455 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7456             if ($ignorecase) {
7457             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7458             }
7459             }
7460              
7461             # $$ --> $$
7462             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7463             }
7464              
7465             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7466 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7467 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7468 0         0 $char[$i] = e_capture($1);
7469             if ($ignorecase) {
7470             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7471             }
7472 0         0 }
7473 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7474 0         0 $char[$i] = e_capture($1);
7475             if ($ignorecase) {
7476             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7477             }
7478             }
7479              
7480 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7481 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7482 0         0 $char[$i] = e_capture($1.'->'.$2);
7483             if ($ignorecase) {
7484             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7485             }
7486             }
7487              
7488 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7489 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7490 0         0 $char[$i] = e_capture($1.'->'.$2);
7491             if ($ignorecase) {
7492             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7493             }
7494             }
7495              
7496 0         0 # $$foo
7497 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7498 0         0 $char[$i] = e_capture($1);
7499             if ($ignorecase) {
7500             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7501             }
7502             }
7503              
7504 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egreek::PREMATCH()
7505 12         35 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7506             if ($ignorecase) {
7507             $char[$i] = '@{[Egreek::ignorecase(Egreek::PREMATCH())]}';
7508 0         0 }
7509             else {
7510             $char[$i] = '@{[Egreek::PREMATCH()]}';
7511             }
7512             }
7513              
7514 12 50       100 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egreek::MATCH()
7515 12         33 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7516             if ($ignorecase) {
7517             $char[$i] = '@{[Egreek::ignorecase(Egreek::MATCH())]}';
7518 0         0 }
7519             else {
7520             $char[$i] = '@{[Egreek::MATCH()]}';
7521             }
7522             }
7523              
7524 12 50       50 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egreek::POSTMATCH()
7525 9         28 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7526             if ($ignorecase) {
7527             $char[$i] = '@{[Egreek::ignorecase(Egreek::POSTMATCH())]}';
7528 0         0 }
7529             else {
7530             $char[$i] = '@{[Egreek::POSTMATCH()]}';
7531             }
7532             }
7533              
7534 9 0       42 # ${ foo }
7535 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7536             if ($ignorecase) {
7537             $char[$i] = '@{[Egreek::ignorecase(' . $1 . ')]}';
7538             }
7539             }
7540              
7541 0         0 # ${ ... }
7542 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7543 0         0 $char[$i] = e_capture($1);
7544             if ($ignorecase) {
7545             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7546             }
7547             }
7548              
7549 0         0 # $scalar or @array
7550 3 50       9 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7551 3         13 $char[$i] = e_string($char[$i]);
7552             if ($ignorecase) {
7553             $char[$i] = '@{[Egreek::ignorecase(' . $char[$i] . ')]}';
7554             }
7555             }
7556              
7557 0 50       0 # quote character before ? + * {
7558             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7559             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7560 1         6 }
7561             else {
7562             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7563             }
7564             }
7565             }
7566 0         0  
7567 74 50       205 # make regexp string
7568 74         163 $modifier =~ tr/i//d;
7569             if ($left_e > $right_e) {
7570 0         0 return join '', 'Egreek::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7571             }
7572             return join '', 'Egreek::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7573             }
7574              
7575             #
7576             # escape regexp of split qr''
7577 74     0 0 713 #
7578 0   0       sub e_split_q {
7579             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7580 0           $modifier ||= '';
7581 0 0          
7582 0           $modifier =~ tr/p//d;
7583 0           if ($modifier =~ /([adlu])/oxms) {
7584 0 0         my $line = 0;
7585 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7586 0           if ($filename ne __FILE__) {
7587             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7588             last;
7589 0           }
7590             }
7591             die qq{Unsupported modifier "$1" used at line $line.\n};
7592 0           }
7593              
7594             $slash = 'div';
7595 0 0          
7596 0           # /b /B modifier
7597             if ($modifier =~ tr/bB//d) {
7598             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7599 0 0         }
7600              
7601             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7602 0            
7603             # split regexp
7604             my @char = $string =~ /\G((?>
7605             [^\\\[] |
7606             [\x00-\xFF] |
7607             \[\^ |
7608             \[\: (?>[a-z]+) \:\] |
7609             \[\:\^ (?>[a-z]+) \:\] |
7610             \\ (?:$q_char) |
7611             (?:$q_char)
7612             ))/oxmsg;
7613 0            
7614 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7615             for (my $i=0; $i <= $#char; $i++) {
7616             if (0) {
7617             }
7618 0            
7619 0           # open character class [...]
7620 0 0         elsif ($char[$i] eq '[') {
7621 0           my $left = $i;
7622             if ($char[$i+1] eq ']') {
7623 0           $i++;
7624 0 0         }
7625 0           while (1) {
7626             if (++$i > $#char) {
7627 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7628 0           }
7629             if ($char[$i] eq ']') {
7630             my $right = $i;
7631 0            
7632             # [...]
7633 0           splice @char, $left, $right-$left+1, Egreek::charlist_qr(@char[$left+1..$right-1], $modifier);
7634 0            
7635             $i = $left;
7636             last;
7637             }
7638             }
7639             }
7640              
7641 0           # open character class [^...]
7642 0 0         elsif ($char[$i] eq '[^') {
7643 0           my $left = $i;
7644             if ($char[$i+1] eq ']') {
7645 0           $i++;
7646 0 0         }
7647 0           while (1) {
7648             if (++$i > $#char) {
7649 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7650 0           }
7651             if ($char[$i] eq ']') {
7652             my $right = $i;
7653 0            
7654             # [^...]
7655 0           splice @char, $left, $right-$left+1, Egreek::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7656 0            
7657             $i = $left;
7658             last;
7659             }
7660             }
7661             }
7662              
7663 0           # rewrite character class or escape character
7664             elsif (my $char = character_class($char[$i],$modifier)) {
7665             $char[$i] = $char;
7666             }
7667              
7668 0           # split(m/^/) --> split(m/^/m)
7669             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7670             $modifier .= 'm';
7671             }
7672              
7673 0 0         # /i modifier
7674 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egreek::uc($char[$i]) ne Egreek::fc($char[$i]))) {
7675             if (CORE::length(Egreek::fc($char[$i])) == 1) {
7676             $char[$i] = '[' . Egreek::uc($char[$i]) . Egreek::fc($char[$i]) . ']';
7677 0           }
7678             else {
7679             $char[$i] = '(?:' . Egreek::uc($char[$i]) . '|' . Egreek::fc($char[$i]) . ')';
7680             }
7681             }
7682              
7683 0 0         # quote character before ? + * {
7684             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7685             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7686 0           }
7687             else {
7688             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7689             }
7690             }
7691 0           }
7692 0            
7693             $modifier =~ tr/i//d;
7694             return join '', 'Egreek::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7695             }
7696              
7697             #
7698             # instead of Carp::carp
7699 0     0 0   #
7700 0           sub carp {
7701             my($package,$filename,$line) = caller(1);
7702             print STDERR "@_ at $filename line $line.\n";
7703             }
7704              
7705             #
7706             # instead of Carp::croak
7707 0     0 0   #
7708 0           sub croak {
7709 0           my($package,$filename,$line) = caller(1);
7710             print STDERR "@_ at $filename line $line.\n";
7711             die "\n";
7712             }
7713              
7714             #
7715             # instead of Carp::cluck
7716 0     0 0   #
7717 0           sub cluck {
7718 0           my $i = 0;
7719 0           my @cluck = ();
7720 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7721             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7722 0           $i++;
7723 0           }
7724 0           print STDERR CORE::reverse @cluck;
7725             print STDERR "\n";
7726             print STDERR @_;
7727             }
7728              
7729             #
7730             # instead of Carp::confess
7731 0     0 0   #
7732 0           sub confess {
7733 0           my $i = 0;
7734 0           my @confess = ();
7735 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7736             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7737 0           $i++;
7738 0           }
7739 0           print STDERR CORE::reverse @confess;
7740 0           print STDERR "\n";
7741             print STDERR @_;
7742             die "\n";
7743             }
7744              
7745             1;
7746              
7747             __END__