File Coverage

blib/lib/Elatin7.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 Elatin7;
2 204     204   1212 use strict;
  204         318  
  204         6096  
3             ######################################################################
4             #
5             # Elatin7 - Run-time routines for Latin7.pm
6             #
7             # http://search.cpan.org/dist/Char-Latin7/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   3440 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         1127  
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   1073 use vars qw($VERSION);
  204         364  
  204         32617  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1874 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         358 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         46352 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   34089 CORE::eval q{
  204     204   2176  
  204     64   411  
  204         40511  
  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       85456 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 (Elatin7::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Elatin7::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   1873 no strict qw(refs);
  204         505  
  204         16359  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   1146 no strict qw(refs);
  204     0   378  
  204         48556  
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   1553 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         363  
  204         14199  
154 204     204   1482 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         571  
  204         396727  
155              
156             #
157             # Latin-7 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Latin-7 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 Elatin7 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182              
183             %lc = (%lc,
184             "\xA8" => "\xB8", # LATIN LETTER O WITH STROKE
185             "\xAA" => "\xBA", # LATIN LETTER R WITH CEDILLA
186             "\xAF" => "\xBF", # LATIN LETTER AE
187             "\xC0" => "\xE0", # LATIN LETTER A WITH OGONEK
188             "\xC1" => "\xE1", # LATIN LETTER I WITH OGONEK
189             "\xC2" => "\xE2", # LATIN LETTER A WITH MACRON
190             "\xC3" => "\xE3", # LATIN LETTER C WITH ACUTE
191             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
192             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
193             "\xC6" => "\xE6", # LATIN LETTER E WITH OGONEK
194             "\xC7" => "\xE7", # LATIN LETTER E WITH MACRON
195             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
196             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
197             "\xCA" => "\xEA", # LATIN LETTER Z WITH ACUTE
198             "\xCB" => "\xEB", # LATIN LETTER E WITH DOT ABOVE
199             "\xCC" => "\xEC", # LATIN LETTER G WITH CEDILLA
200             "\xCD" => "\xED", # LATIN LETTER K WITH CEDILLA
201             "\xCE" => "\xEE", # LATIN LETTER I WITH MACRON
202             "\xCF" => "\xEF", # LATIN LETTER L WITH CEDILLA
203             "\xD0" => "\xF0", # LATIN LETTER S WITH CARON
204             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
205             "\xD2" => "\xF2", # LATIN LETTER N WITH CEDILLA
206             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
207             "\xD4" => "\xF4", # LATIN LETTER O WITH MACRON
208             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
209             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
210             "\xD8" => "\xF8", # LATIN LETTER U WITH OGONEK
211             "\xD9" => "\xF9", # LATIN LETTER L WITH STROKE
212             "\xDA" => "\xFA", # LATIN LETTER S WITH ACUTE
213             "\xDB" => "\xFB", # LATIN LETTER U WITH MACRON
214             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
215             "\xDD" => "\xFD", # LATIN LETTER Z WITH DOT ABOVE
216             "\xDE" => "\xFE", # LATIN LETTER Z WITH CARON
217             );
218              
219             %uc = (%uc,
220             "\xB8" => "\xA8", # LATIN LETTER O WITH STROKE
221             "\xBA" => "\xAA", # LATIN LETTER R WITH CEDILLA
222             "\xBF" => "\xAF", # LATIN LETTER AE
223             "\xE0" => "\xC0", # LATIN LETTER A WITH OGONEK
224             "\xE1" => "\xC1", # LATIN LETTER I WITH OGONEK
225             "\xE2" => "\xC2", # LATIN LETTER A WITH MACRON
226             "\xE3" => "\xC3", # LATIN LETTER C WITH ACUTE
227             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
228             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
229             "\xE6" => "\xC6", # LATIN LETTER E WITH OGONEK
230             "\xE7" => "\xC7", # LATIN LETTER E WITH MACRON
231             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
232             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
233             "\xEA" => "\xCA", # LATIN LETTER Z WITH ACUTE
234             "\xEB" => "\xCB", # LATIN LETTER E WITH DOT ABOVE
235             "\xEC" => "\xCC", # LATIN LETTER G WITH CEDILLA
236             "\xED" => "\xCD", # LATIN LETTER K WITH CEDILLA
237             "\xEE" => "\xCE", # LATIN LETTER I WITH MACRON
238             "\xEF" => "\xCF", # LATIN LETTER L WITH CEDILLA
239             "\xF0" => "\xD0", # LATIN LETTER S WITH CARON
240             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
241             "\xF2" => "\xD2", # LATIN LETTER N WITH CEDILLA
242             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
243             "\xF4" => "\xD4", # LATIN LETTER O WITH MACRON
244             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
245             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
246             "\xF8" => "\xD8", # LATIN LETTER U WITH OGONEK
247             "\xF9" => "\xD9", # LATIN LETTER L WITH STROKE
248             "\xFA" => "\xDA", # LATIN LETTER S WITH ACUTE
249             "\xFB" => "\xDB", # LATIN LETTER U WITH MACRON
250             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
251             "\xFD" => "\xDD", # LATIN LETTER Z WITH DOT ABOVE
252             "\xFE" => "\xDE", # LATIN LETTER Z WITH CARON
253             );
254              
255             %fc = (%fc,
256             "\xA8" => "\xB8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
257             "\xAA" => "\xBA", # LATIN CAPITAL LETTER R WITH CEDILLA --> LATIN SMALL LETTER R WITH CEDILLA
258             "\xAF" => "\xBF", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
259             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
260             "\xC1" => "\xE1", # LATIN CAPITAL LETTER I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
261             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
262             "\xC3" => "\xE3", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
263             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
264             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
265             "\xC6" => "\xE6", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
266             "\xC7" => "\xE7", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
267             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
268             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
269             "\xCA" => "\xEA", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
270             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
271             "\xCC" => "\xEC", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
272             "\xCD" => "\xED", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
273             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
274             "\xCF" => "\xEF", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
275             "\xD0" => "\xF0", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
276             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
277             "\xD2" => "\xF2", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
278             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
279             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
280             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
281             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
282             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
283             "\xD9" => "\xF9", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
284             "\xDA" => "\xFA", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
285             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
286             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
287             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
288             "\xDE" => "\xFE", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
289             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
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 = Elatin7::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 = Elatin7::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 = \&Latin7::ord;
335 0         0 *Char::ord_ = \&Latin7::ord_;
336 0         0 *Char::reverse = \&Latin7::reverse;
337 0         0 *Char::getc = \&Latin7::getc;
338 0         0 *Char::length = \&Latin7::length;
339 0         0 *Char::substr = \&Latin7::substr;
340 0         0 *Char::index = \&Latin7::index;
341 0         0 *Char::rindex = \&Latin7::rindex;
342 0         0 *Char::eval = \&Latin7::eval;
343 0         0 *Char::escape = \&Latin7::escape;
344 0         0 *Char::escape_token = \&Latin7::escape_token;
345 0         0 *Char::escape_script = \&Latin7::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 Elatin7::split(;$$$);
371             sub Elatin7::tr($$$$;$);
372             sub Elatin7::chop(@);
373             sub Elatin7::index($$;$);
374             sub Elatin7::rindex($$;$);
375             sub Elatin7::lcfirst(@);
376             sub Elatin7::lcfirst_();
377             sub Elatin7::lc(@);
378             sub Elatin7::lc_();
379             sub Elatin7::ucfirst(@);
380             sub Elatin7::ucfirst_();
381             sub Elatin7::uc(@);
382             sub Elatin7::uc_();
383             sub Elatin7::fc(@);
384             sub Elatin7::fc_();
385             sub Elatin7::ignorecase;
386             sub Elatin7::classic_character_class;
387             sub Elatin7::capture;
388             sub Elatin7::chr(;$);
389             sub Elatin7::chr_();
390             sub Elatin7::glob($);
391             sub Elatin7::glob_();
392              
393             sub Latin7::ord(;$);
394             sub Latin7::ord_();
395             sub Latin7::reverse(@);
396             sub Latin7::getc(;*@);
397             sub Latin7::length(;$);
398             sub Latin7::substr($$;$$);
399             sub Latin7::index($$;$);
400             sub Latin7::rindex($$;$);
401             sub Latin7::escape(;$);
402              
403             #
404             # Regexp work
405             #
406 204         22511 use vars qw(
407             $re_a
408             $re_t
409             $re_n
410             $re_r
411 204     204   1739 );
  204         527  
412              
413             #
414             # Character class
415             #
416 204         2317811 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   1289 );
  204         364  
445              
446             ${Elatin7::dot} = qr{(?>[^\x0A])};
447             ${Elatin7::dot_s} = qr{(?>[\x00-\xFF])};
448             ${Elatin7::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             # ${Elatin7::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
454             # ${Elatin7::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
455             ${Elatin7::eS} = qr{(?>[^\s])};
456              
457             ${Elatin7::eW} = qr{(?>[^0-9A-Z_a-z])};
458             ${Elatin7::eH} = qr{(?>[^\x09\x20])};
459             ${Elatin7::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
460             ${Elatin7::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
461             ${Elatin7::eN} = qr{(?>[^\x0A])};
462             ${Elatin7::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
463             ${Elatin7::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
464             ${Elatin7::not_ascii} = qr{(?>[^\x00-\x7F])};
465             ${Elatin7::not_blank} = qr{(?>[^\x09\x20])};
466             ${Elatin7::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
467             ${Elatin7::not_digit} = qr{(?>[^\x30-\x39])};
468             ${Elatin7::not_graph} = qr{(?>[^\x21-\x7F])};
469             ${Elatin7::not_lower} = qr{(?>[^\x61-\x7A])};
470             ${Elatin7::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
471             # ${Elatin7::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
472             ${Elatin7::not_print} = qr{(?>[^\x20-\x7F])};
473             ${Elatin7::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
474             ${Elatin7::not_space} = qr{(?>[^\s\x0B])};
475             ${Elatin7::not_upper} = qr{(?>[^\x41-\x5A])};
476             ${Elatin7::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
477             # ${Elatin7::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
478             ${Elatin7::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
479             ${Elatin7::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
480             ${Elatin7::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
481             ${Elatin7::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
482              
483             # avoid: Name "Elatin7::foo" used only once: possible typo at here.
484             ${Elatin7::dot} = ${Elatin7::dot};
485             ${Elatin7::dot_s} = ${Elatin7::dot_s};
486             ${Elatin7::eD} = ${Elatin7::eD};
487             ${Elatin7::eS} = ${Elatin7::eS};
488             ${Elatin7::eW} = ${Elatin7::eW};
489             ${Elatin7::eH} = ${Elatin7::eH};
490             ${Elatin7::eV} = ${Elatin7::eV};
491             ${Elatin7::eR} = ${Elatin7::eR};
492             ${Elatin7::eN} = ${Elatin7::eN};
493             ${Elatin7::not_alnum} = ${Elatin7::not_alnum};
494             ${Elatin7::not_alpha} = ${Elatin7::not_alpha};
495             ${Elatin7::not_ascii} = ${Elatin7::not_ascii};
496             ${Elatin7::not_blank} = ${Elatin7::not_blank};
497             ${Elatin7::not_cntrl} = ${Elatin7::not_cntrl};
498             ${Elatin7::not_digit} = ${Elatin7::not_digit};
499             ${Elatin7::not_graph} = ${Elatin7::not_graph};
500             ${Elatin7::not_lower} = ${Elatin7::not_lower};
501             ${Elatin7::not_lower_i} = ${Elatin7::not_lower_i};
502             ${Elatin7::not_print} = ${Elatin7::not_print};
503             ${Elatin7::not_punct} = ${Elatin7::not_punct};
504             ${Elatin7::not_space} = ${Elatin7::not_space};
505             ${Elatin7::not_upper} = ${Elatin7::not_upper};
506             ${Elatin7::not_upper_i} = ${Elatin7::not_upper_i};
507             ${Elatin7::not_word} = ${Elatin7::not_word};
508             ${Elatin7::not_xdigit} = ${Elatin7::not_xdigit};
509             ${Elatin7::eb} = ${Elatin7::eb};
510             ${Elatin7::eB} = ${Elatin7::eB};
511              
512             #
513             # Latin-7 split
514             #
515             sub Elatin7::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             # Latin-7 transliteration (tr///)
725             #
726             sub Elatin7::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             # Latin-7 chop
816             #
817             sub Elatin7::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             # Latin-7 index by octet
837             #
838             sub Elatin7::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             # Latin-7 reverse index
862             #
863             sub Elatin7::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             # Latin-7 lower case first with parameter
886             #
887             sub Elatin7::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 Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
892             }
893             else {
894 0         0 return Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
895             }
896             }
897             else {
898 0         0 return Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
899             }
900             }
901              
902             #
903             # Latin-7 lower case first without parameter
904             #
905             sub Elatin7::lcfirst_() {
906 0     0 0 0 return Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
907             }
908              
909             #
910             # Latin-7 lower case with parameter
911             #
912             sub Elatin7::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 Elatin7::lc_();
924             }
925             }
926              
927             #
928             # Latin-7 lower case without parameter
929             #
930             sub Elatin7::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             # Latin-7 upper case first with parameter
937             #
938             sub Elatin7::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 Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
943             }
944             else {
945 0         0 return Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
946             }
947             }
948             else {
949 0         0 return Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
950             }
951             }
952              
953             #
954             # Latin-7 upper case first without parameter
955             #
956             sub Elatin7::ucfirst_() {
957 0     0 0 0 return Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
958             }
959              
960             #
961             # Latin-7 upper case with parameter
962             #
963             sub Elatin7::uc(@) {
964 0 50   174 0 0 if (@_) {
965 174         272 my $s = shift @_;
966 174 50 33     214 if (@_ and wantarray) {
967 174 0       360 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         583  
971             }
972             }
973             else {
974 174         837 return Elatin7::uc_();
975             }
976             }
977              
978             #
979             # Latin-7 upper case without parameter
980             #
981             sub Elatin7::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             # Latin-7 fold case with parameter
988             #
989             sub Elatin7::fc(@) {
990 0 50   197 0 0 if (@_) {
991 197         277 my $s = shift @_;
992 197 50 33     314 if (@_ and wantarray) {
993 197 0       335 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         487  
997             }
998             }
999             else {
1000 197         1130 return Elatin7::fc_();
1001             }
1002             }
1003              
1004             #
1005             # Latin-7 fold case without parameter
1006             #
1007             sub Elatin7::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             # Latin-7 regexp capture
1014             #
1015             {
1016             sub Elatin7::capture {
1017 0     0 1 0 return $_[0];
1018             }
1019             }
1020              
1021             #
1022             # Latin-7 regexp ignore case modifier
1023             #
1024             sub Elatin7::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 = Elatin7::uc($char[$i]);
1121 0         0 my $fc = Elatin7::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 Elatin7::classic_character_class {
1159 0     1867 0 0 my($char) = @_;
1160              
1161             return {
1162             '\D' => '${Elatin7::eD}',
1163             '\S' => '${Elatin7::eS}',
1164             '\W' => '${Elatin7::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' => '${Elatin7::eH}',
1207             '\V' => '${Elatin7::eV}',
1208             '\h' => '[\x09\x20]',
1209             '\v' => '[\x0A\x0B\x0C\x0D]',
1210             '\R' => '${Elatin7::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' => '${Elatin7::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' => '${Elatin7::eb}',
1233              
1234             # \B really means (?:(?<=\w)(?=\w)|(?
1235             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1236             '\B' => '${Elatin7::eB}',
1237              
1238 1867   100     2659 }->{$char} || '';
1239             }
1240              
1241             #
1242             # prepare Latin-7 characters per length
1243             #
1244              
1245             # 1 octet characters
1246             my @chars1 = ();
1247             sub chars1 {
1248 1867 0   0 0 67460 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             # Latin-7 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             # Latin-7 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             # Latin-7 octet range
1494             #
1495             sub _octets {
1496 0     182   0 my $length = shift @_;
1497              
1498 182 50       306 if ($length == 1) {
1499 182         441 my($a1) = unpack 'C', $_[0];
1500 182         512 my($z1) = unpack 'C', $_[1];
1501              
1502 182 50       319 if ($a1 > $z1) {
1503 182         339 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         437 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         1157 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1518             }
1519             }
1520              
1521             #
1522             # Latin-7 range regexp
1523             #
1524             sub _range_regexp {
1525 0     182   0 my($length,$first,$last) = @_;
1526              
1527 182         449 my @range_regexp = ();
1528 182 50       249 if (not exists $range_tr{$length}) {
1529 182         441 return @range_regexp;
1530             }
1531              
1532 0         0 my @ranges = @{ $range_tr{$length} };
  182         271  
1533 182         393 while (my @range = splice(@ranges,0,$length)) {
1534 182         563 my $min = '';
1535 182         272 my $max = '';
1536 182         226 for (my $i=0; $i < $length; $i++) {
1537 182         487 $min .= pack 'C', $range[$i][0];
1538 182         656 $max .= pack 'C', $range[$i][-1];
1539             }
1540              
1541             # min___max
1542             # FIRST_____________LAST
1543             # (nothing)
1544              
1545 182 50 33     432 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         1784 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         449 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             # Latin-7 open character list for qr and not qr
1610             #
1611             sub _charlist {
1612              
1613 182     358   386 my $modifier = pop @_;
1614 358         636 my @char = @_;
1615              
1616 358 100       893 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1617              
1618             # unescape character
1619 358         823 for (my $i=0; $i <= $#char; $i++) {
1620              
1621             # escape - to ...
1622 358 100 100     1399 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1623 1125 100 100     8786 if ((0 < $i) and ($i < $#char)) {
1624 206         1829 $char[$i] = '...';
1625             }
1626             }
1627              
1628             # octal escape sequence
1629             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1630 182         367 $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         108 $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' => '${Elatin7::eD}',
1683             '\S' => '${Elatin7::eS}',
1684             '\W' => '${Elatin7::eW}',
1685              
1686             '\H' => '${Elatin7::eH}',
1687             '\V' => '${Elatin7::eV}',
1688             '\h' => '[\x09\x20]',
1689             '\v' => '[\x0A\x0B\x0C\x0D]',
1690             '\R' => '${Elatin7::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:]' => '${Elatin7::not_lower_i}',
1702             '[:^upper:]' => '${Elatin7::not_upper_i}',
1703              
1704 25         491 }->{$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:]' => '${Elatin7::not_alnum}',
1738             '[:^alpha:]' => '${Elatin7::not_alpha}',
1739             '[:^ascii:]' => '${Elatin7::not_ascii}',
1740             '[:^blank:]' => '${Elatin7::not_blank}',
1741             '[:^cntrl:]' => '${Elatin7::not_cntrl}',
1742             '[:^digit:]' => '${Elatin7::not_digit}',
1743             '[:^graph:]' => '${Elatin7::not_graph}',
1744             '[:^lower:]' => '${Elatin7::not_lower}',
1745             '[:^print:]' => '${Elatin7::not_print}',
1746             '[:^punct:]' => '${Elatin7::not_punct}',
1747             '[:^space:]' => '${Elatin7::not_space}',
1748             '[:^upper:]' => '${Elatin7::not_upper}',
1749             '[:^word:]' => '${Elatin7::not_word}',
1750             '[:^xdigit:]' => '${Elatin7::not_xdigit}',
1751              
1752 8         88 }->{$1};
1753             }
1754             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1755 70         1595 $char[$i] = $1;
1756             }
1757             }
1758              
1759             # open character list
1760 7         34 my @singleoctet = ();
1761 358         625 my @multipleoctet = ();
1762 358         579 for (my $i=0; $i <= $#char; ) {
1763              
1764             # escaped -
1765 358 100 100     914 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1766 943         4115 $i += 1;
1767 182         258 next;
1768             }
1769              
1770             # make range regexp
1771             elsif ($char[$i] eq '...') {
1772              
1773             # range error
1774 182 50       1407 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1775 182         690 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         468 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         498 my @regexp = ();
1786              
1787             # is first and last
1788 182 50 33     267 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1789 182         646 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         466 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         413 push @singleoctet, @regexp;
1813             }
1814             else {
1815 182         402 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       371 if ($modifier =~ /i/oxms) {
1825 493         804 my $uc = Elatin7::uc($char[$i]);
1826 24         49 my $fc = Elatin7::fc($char[$i]);
1827 24 100       48 if ($uc ne $fc) {
1828 24 50       45 if (CORE::length($fc) == 1) {
1829 12         22 push @singleoctet, $uc, $fc;
1830             }
1831             else {
1832 12         21 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         25 push @singleoctet, $char[$i];
1842             }
1843 469         684 $i += 1;
1844             }
1845              
1846             # single character of single octet code
1847             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1848 493         813 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         6 $i += 1;
1858             }
1859              
1860             # single character of multiple-octet code
1861             else {
1862 2         5 push @multipleoctet, $char[$i];
1863 84         162 $i += 1;
1864             }
1865             }
1866              
1867             # quote metachar
1868 84         805 for (@singleoctet) {
1869 358 50       944 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1870 689         3262 $_ = '-';
1871             }
1872             elsif (/\A \n \z/oxms) {
1873 0         0 $_ = '\n';
1874             }
1875             elsif (/\A \r \z/oxms) {
1876 8         18 $_ = '\r';
1877             }
1878             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1879 8         19 $_ = sprintf('\x%02X', CORE::ord $1);
1880             }
1881             elsif (/\A [\x00-\xFF] \z/oxms) {
1882 60         210 $_ = quotemeta $_;
1883             }
1884             }
1885              
1886             # return character list
1887 429         799 return \@singleoctet, \@multipleoctet;
1888             }
1889              
1890             #
1891             # Latin-7 octal escape sequence
1892             #
1893             sub octchr {
1894 358     5 0 1460 my($octdigit) = @_;
1895              
1896 5         14 my @binary = ();
1897 5         9 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         24 }->{$octal};
1908             }
1909 50         175 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         13 }->{CORE::length($binary) % 8};
1923              
1924 5         61 return $octchr;
1925             }
1926              
1927             #
1928             # Latin-7 hexadecimal escape sequence
1929             #
1930             sub hexchr {
1931 5     5 0 20 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         55 return $hexchr;
1940             }
1941              
1942             #
1943             # Latin-7 open character list for qr
1944             #
1945             sub charlist_qr {
1946              
1947 5     314 0 18 my $modifier = pop @_;
1948 314         703 my @char = @_;
1949              
1950 314         951 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1951 314         1464 my @singleoctet = @$singleoctet;
1952 314         726 my @multipleoctet = @$multipleoctet;
1953              
1954             # return character list
1955 314 100       583 if (scalar(@singleoctet) >= 1) {
1956              
1957             # with /i modifier
1958 314 100       745 if ($modifier =~ m/i/oxms) {
1959 236         536 my %singleoctet_ignorecase = ();
1960 22         42 for (@singleoctet) {
1961 22   100     47 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1962 46         201 for my $ord (hex($1) .. hex($2)) {
1963 46         127 my $char = CORE::chr($ord);
1964 66         100 my $uc = Elatin7::uc($char);
1965 66         95 my $fc = Elatin7::fc($char);
1966 66 100       107 if ($uc eq $fc) {
1967 66         108 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1968             }
1969             else {
1970 12 50       79 if (CORE::length($fc) == 1) {
1971 54         91 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1972 54         115 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1973             }
1974             else {
1975 54         242 $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         97 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1983             }
1984             }
1985 0         0 my $i = 0;
1986 22         29 my @singleoctet_ignorecase = ();
1987 22         30 for my $ord (0 .. 255) {
1988 22 100       38 if (exists $singleoctet_ignorecase{$ord}) {
1989 5632         7247 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         140  
1990             }
1991             else {
1992 96         269 $i++;
1993             }
1994             }
1995 5536         6028 @singleoctet = ();
1996 22         39 for my $range (@singleoctet_ignorecase) {
1997 22 100       70 if (ref $range) {
1998 3648 100       5767 if (scalar(@{$range}) == 1) {
  56 50       54  
1999 56         162 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         43  
2000             }
2001 36         112 elsif (scalar(@{$range}) == 2) {
2002 20         29 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         23  
  20         26  
2006             }
2007             }
2008             }
2009             }
2010              
2011 20         96 my $not_anchor = '';
2012              
2013 236         379 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2014             }
2015 236 100       644 if (scalar(@multipleoctet) >= 2) {
2016 314         678 return '(?:' . join('|', @multipleoctet) . ')';
2017             }
2018             else {
2019 6         32 return $multipleoctet[0];
2020             }
2021             }
2022              
2023             #
2024             # Latin-7 open character list for not qr
2025             #
2026             sub charlist_not_qr {
2027              
2028 308     44 0 1321 my $modifier = pop @_;
2029 44         107 my @char = @_;
2030              
2031 44         111 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2032 44         127 my @singleoctet = @$singleoctet;
2033 44         106 my @multipleoctet = @$multipleoctet;
2034              
2035             # with /i modifier
2036 44 100       70 if ($modifier =~ m/i/oxms) {
2037 44         127 my %singleoctet_ignorecase = ();
2038 10         17 for (@singleoctet) {
2039 10   66     12 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2040 10         48 for my $ord (hex($1) .. hex($2)) {
2041 10         37 my $char = CORE::chr($ord);
2042 30         47 my $uc = Elatin7::uc($char);
2043 30         48 my $fc = Elatin7::fc($char);
2044 30 50       54 if ($uc eq $fc) {
2045 30         53 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2046             }
2047             else {
2048 0 50       0 if (CORE::length($fc) == 1) {
2049 30         52 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2050 30         67 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2051             }
2052             else {
2053 30         107 $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         27 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2061             }
2062             }
2063 0         0 my $i = 0;
2064 10         14 my @singleoctet_ignorecase = ();
2065 10         14 for my $ord (0 .. 255) {
2066 10 100       16 if (exists $singleoctet_ignorecase{$ord}) {
2067 2560         3208 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         65  
2068             }
2069             else {
2070 60         120 $i++;
2071             }
2072             }
2073 2500         2955 @singleoctet = ();
2074 10         14 for my $range (@singleoctet_ignorecase) {
2075 10 100       28 if (ref $range) {
2076 960 50       1714 if (scalar(@{$range}) == 1) {
  20 50       22  
2077 20         37 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2078             }
2079 0         0 elsif (scalar(@{$range}) == 2) {
2080 20         26 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         27  
  20         26  
2084             }
2085             }
2086             }
2087             }
2088              
2089             # return character list
2090 20 50       80 if (scalar(@multipleoctet) >= 1) {
2091 44 0       114 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         105 return '(?:[^' . join('', @singleoctet) . '])';
2107             }
2108             else {
2109              
2110             # any character
2111 44         275 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   3138 use Fcntl qw(O_RDONLY);
  204         867  
  204         52898  
2122 408         1238 return CORE::sysopen($_[0], $file, &O_RDONLY);
2123             }
2124              
2125             #
2126             # open file in append mode
2127             #
2128             sub _open_a {
2129 408     204   18995 my(undef,$file) = @_;
2130 204     204   2054 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         525  
  204         709558  
2131 204         717 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   27569 $| = 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         1964 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         1878 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         427  
2214             }
2215              
2216             #
2217             # Latin-7 order to character (with parameter)
2218             #
2219             sub Elatin7::chr(;$) {
2220              
2221 204 0   0 0 20835076 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             # Latin-7 order to character (without parameter)
2238             #
2239             sub Elatin7::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             # Latin-7 path globbing (with parameter)
2258             #
2259             sub Elatin7::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             # Latin-7 path globbing (without parameter)
2277             #
2278             sub Elatin7::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             # Latin-7 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             # Latin-7 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 = Elatin7::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 { Elatin7::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 (Elatin7::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 Elatin7::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             # Latin-7 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             # Latin-7 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 Elatin7::PREMATCH {
2619             return $`;
2620             }
2621              
2622             #
2623             # ${^MATCH}, $MATCH, $& the string that matched
2624 0     0 0 0 #
2625             sub Elatin7::MATCH {
2626             return $&;
2627             }
2628              
2629             #
2630             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2631 0     0 0 0 #
2632             sub Elatin7::POSTMATCH {
2633             return $';
2634             }
2635              
2636             #
2637             # Latin-7 character to order (with parameter)
2638             #
2639 0 0   0 1 0 sub Latin7::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             # Latin-7 character to order (without parameter)
2658             #
2659 0 0   0 0 0 sub Latin7::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             # Latin-7 reverse
2676             #
2677 0 0   0 0 0 sub Latin7::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             # Latin-7 getc (with parameter, without parameter)
2695             #
2696 0     0 0 0 sub Latin7::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 Latin7::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 ${Elatin7::dot_s} \z/oxms) {
2708             return wantarray ? ($getc,@_) : $getc;
2709             }
2710 0 0       0 }
2711             }
2712             return wantarray ? ($getc,@_) : $getc;
2713             }
2714              
2715             #
2716             # Latin-7 length by character
2717             #
2718 0 0   0 1 0 sub Latin7::length(;$) {
2719              
2720 0         0 local $_ = shift if @_;
2721 0         0  
2722             local @_ = /\G ($q_char) /oxmsg;
2723             return scalar @_;
2724             }
2725              
2726             #
2727             # Latin-7 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 133858 # 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 Latin7::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             # Latin-7 index by character
2819             #
2820 0     0 1 0 sub Latin7::index($$;$) {
2821 0 0       0  
2822 0         0 my $index;
2823             if (@_ == 3) {
2824             $index = Elatin7::index($_[0], $_[1], CORE::length(Latin7::substr($_[0], 0, $_[2])));
2825 0         0 }
2826             else {
2827             $index = Elatin7::index($_[0], $_[1]);
2828 0 0       0 }
2829 0         0  
2830             if ($index == -1) {
2831             return -1;
2832 0         0 }
2833             else {
2834             return Latin7::length(CORE::substr $_[0], 0, $index);
2835             }
2836             }
2837              
2838             #
2839             # Latin-7 rindex by character
2840             #
2841 0     0 1 0 sub Latin7::rindex($$;$) {
2842 0 0       0  
2843 0         0 my $rindex;
2844             if (@_ == 3) {
2845             $rindex = Elatin7::rindex($_[0], $_[1], CORE::length(Latin7::substr($_[0], 0, $_[2])));
2846 0         0 }
2847             else {
2848             $rindex = Elatin7::rindex($_[0], $_[1]);
2849 0 0       0 }
2850 0         0  
2851             if ($rindex == -1) {
2852             return -1;
2853 0         0 }
2854             else {
2855             return Latin7::length(CORE::substr $_[0], 0, $rindex);
2856             }
2857             }
2858              
2859 204     204   1855 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         441  
  204         28592  
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 Latin7::ord()
2864             my $function_ord = 'ord';
2865              
2866             # ord to ord or Latin7::ord_
2867             my $function_ord_ = 'ord';
2868              
2869             # reverse to reverse or Latin7::reverse
2870             my $function_reverse = 'reverse';
2871              
2872             # getc to getc or Latin7::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   1428 my $anchor = '';
  204     0   413  
  204         10477985  
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 | Latin7::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 Latin-7 script
2988 0 50   204 0 0 #
2989             sub Latin7::escape(;$) {
2990             local($_) = $_[0] if @_;
2991              
2992             # P.359 The Study Function
2993             # in Chapter 7: Perl
2994 204         749 # 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         500 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3016 204         6057  
3017 204         787 my $e_script = '';
3018             while (not /\G \z/oxgc) { # member
3019             $e_script .= Latin7::escape_token();
3020 74767         116064 }
3021              
3022             return $e_script;
3023             }
3024              
3025             #
3026             # escape Latin-7 token of script
3027             #
3028             sub Latin7::escape_token {
3029              
3030 204     74767 0 2752 # \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 74767 100 100     108450 # 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 74767         3089337  
3051 12511 100       17019 if (/\G ( \n ) /oxgc) { # another member (and so on)
3052 12511         21940 my $heredoc = '';
3053             if (scalar(@heredoc_delimiter) >= 1) {
3054 174         216 $slash = 'm//';
3055 174         358  
3056             $heredoc = join '', @heredoc;
3057             @heredoc = ();
3058 174         290  
3059 174         303 # skip here document
3060             for my $heredoc_delimiter (@heredoc_delimiter) {
3061 174         1065 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3062             }
3063 174         308 @heredoc_delimiter = ();
3064              
3065 174         224 $here_script = '';
3066             }
3067             return "\n" . $heredoc;
3068             }
3069 12511         38418  
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 17919         58964  
3085 1401         2299 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 1401         4316  
3105             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3106 86 50       213 my $e_string = e_string($1);
    50          
3107 86         2357  
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         144 else {
3121             $slash = 'div';
3122             return $e_string;
3123             }
3124             }
3125              
3126 86         292 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
3127 4         11 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3128             $slash = 'div';
3129             return q{Elatin7::PREMATCH()};
3130             }
3131              
3132 4         16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
3133 28         52 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3134             $slash = 'div';
3135             return q{Elatin7::MATCH()};
3136             }
3137              
3138 28         90 # $', ${'} --> $', ${'}
3139 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3140             $slash = 'div';
3141             return $1;
3142             }
3143              
3144 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
3145 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3146             $slash = 'div';
3147             return q{Elatin7::POSTMATCH()};
3148             }
3149              
3150             # scalar variable $scalar =~ tr///;
3151             # scalar variable $scalar =~ s///;
3152             # substr() =~ tr///;
3153 3         10 # substr() =~ s///;
3154             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3155 1671 100       3621 my $scalar = e_string($1);
    100          
3156 1671         6329  
3157 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3158 1         2 $tr_variable = $scalar;
3159 1         2 $bind_operator = $1;
3160             $slash = 'm//';
3161             return '';
3162 1         4 }
3163 61         123 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3164 61         108 $sub_variable = $scalar;
3165 61         99 $bind_operator = $1;
3166             $slash = 'm//';
3167             return '';
3168 61         171 }
3169 1609         2345 else {
3170             $slash = 'div';
3171             return $scalar;
3172             }
3173             }
3174              
3175 1609         4084 # end of statement
3176             elsif (/\G ( [,;] ) /oxgc) {
3177             $slash = 'm//';
3178 4987         24705  
3179             # clear tr/// variable
3180             $tr_variable = '';
3181 4987         6010  
3182             # clear s/// variable
3183 4987         5621 $sub_variable = '';
3184              
3185 4987         5670 $bind_operator = '';
3186              
3187             return $1;
3188             }
3189              
3190 4987         17218 # bareword
3191             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3192             return $1;
3193             }
3194              
3195 0         0 # $0 --> $0
3196 2         4 elsif (/\G ( \$ 0 ) /oxmsgc) {
3197             $slash = 'div';
3198             return $1;
3199 2         8 }
3200 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3201             $slash = 'div';
3202             return $1;
3203             }
3204              
3205 0         0 # $$ --> $$
3206 1         3 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         3 # $1, $2, $3 --> $1, $2, $3 otherwise
3213 4         6 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         109 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         151 # $ @ # \ ' " / ? ( ) [ ] < >
3260 62         141 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3261             $slash = 'div';
3262             return $1;
3263             }
3264              
3265 62         223 # 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 ($_ = Elatin7::glob("' . $1 . '"))';
3276             }
3277              
3278 0         0 # while (glob)
3279             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3280             return 'while ($_ = Elatin7::glob_)';
3281             }
3282              
3283 0         0 # while (glob(WILDCARD))
3284             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3285             return 'while ($_ = Elatin7::glob';
3286             }
3287 0         0  
  248         544  
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 248         880  
  19         34  
3291 19         65 # subroutines of package Elatin7
  0         0  
3292 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         25  
3293 13         30 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3294 0         0 elsif (/\G \b Latin7::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         182  
3295 114         318 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3296 2         7 elsif (/\G \b Latin7::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin7::escape'; }
  0         0  
3297 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3298 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::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 Latin7::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin7::index'; }
  2         5  
3302 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::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 Latin7::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin7::rindex'; }
  1         3  
3306 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::rindex'; }
  0         0  
3307 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::lc'; }
  1         2  
3308 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::lcfirst'; }
  0         0  
3309 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::uc'; }
  6         9  
3310             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::ucfirst'; }
3311             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::fc'; }
3312 6         21  
  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         3  
3335 2         7  
  2         4  
3336 2         6 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         68  
3337 36         117 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         6  
3338 2         10 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::chr'; }
  8         15  
3339 8         22 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 'Elatin7::glob'; }
  0         0  
3342 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::lc_'; }
  0         0  
3343 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::lcfirst_'; }
  0         0  
3344 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::uc_'; }
  0         0  
3345 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::ucfirst_'; }
  0         0  
3346             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::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 'Elatin7::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 'Elatin7::glob_'; }
  8         20  
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         30 # split
3358             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3359 87         182 $slash = 'm//';
3360 87         135  
3361 87         307 my $e = '';
3362             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3363             $e .= $1;
3364             }
3365 85 100       327  
  87 100       6299  
    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 'Elatin7::split' . $e; }
3368 2         10  
3369             # split scalar value
3370             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin7::split' . $e . e_string($1); }
3371 1         6  
3372 0         0 # split literal space
3373 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin7::split' . $e . qq {qq$1 $2}; }
3374 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3375 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3376 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3377 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3378 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3379 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin7::split' . $e . qq {q$1 $2}; }
3380 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3381 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3382 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3383 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3384 10         44 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3385             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin7::split' . $e . qq {' '}; }
3386             elsif (/\G " [ ] " /oxgc) { return 'Elatin7::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         414  
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       62 else {
  12 50       3125  
    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         83 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         490  
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       76 else {
  18 50       4506  
    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         114 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         109 elsif (/\G (\/) /oxgc) {
3484 44 50       156 my $regexp = '';
  381 50       1650  
    100          
    50          
3485 0         0 while (not /\G \z/oxgc) {
3486 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3487 44         184 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3488             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3489 337         727 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       7  
3506 3         48 # $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         4 else {
3512 3 50       10 my $e = '';
  3 50       216  
    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         10 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 2180 50       18809  
3577 2180         4262 # 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 2180         2820 else {
3590 2180 50       5268 my $e = '';
  2180 50       9031  
    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 2150         3229 elsif (/\G (\{) /oxgc) { # qq { }
3613 2150         2972 my $qq_string = '';
3614 2150 100       4418 local $nest = 1;
  84006 50       271609  
    100          
    100          
    50          
3615 722         1491 while (not /\G \z/oxgc) {
3616 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1720  
3617             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3618 1153 100       1930 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5452  
3619 2150         4531 elsif (/\G (\}) /oxgc) {
3620             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3621 1153         2308 else { $qq_string .= $1; }
3622             }
3623 78828         158848 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         49 elsif (/\G (\<) /oxgc) { # qq < >
3647 30         56 my $qq_string = '';
3648 30 100       143 local $nest = 1;
  1166 50       5156  
    50          
    100          
    50          
3649 22         49 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         63  
3653 30         74 elsif (/\G (\>) /oxgc) {
3654             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3655 0         0 else { $qq_string .= $1; }
3656             }
3657 1114         2253 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       46 elsif (/\G \b (qw) \b /oxgc) {
3703 16         99 my $ope = $1;
3704             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3705             return e_qw($ope,$1,$3,$2);
3706 0         0 }
3707 16         31 else {
3708 16 50       54 my $e = '';
  16 50       96  
    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         53  
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       1084 # (and so on)
3760 410         2077  
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         1912 else {
3773 410 50       1203 my $e = '';
  410 50       4469  
    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         915 elsif (/\G (\{) /oxgc) { # q { }
3797 404         709 my $q_string = '';
3798 404 50       1226 local $nest = 1;
  6770 50       29143  
    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         176  
3802             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3803 107 100       194 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         1516  
3804 404         1193 elsif (/\G (\}) /oxgc) {
3805             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3806 107         229 else { $q_string .= $1; }
3807             }
3808 6152         30800 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         9 elsif (/\G (\<) /oxgc) { # q < >
3833 5         10 my $q_string = '';
3834 5 50       18 local $nest = 1;
  88 50       354  
    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         21  
3840 5         11 elsif (/\G (\>) /oxgc) {
3841             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3842 0         0 else { $q_string .= $1; }
3843             }
3844 83         159 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       5 my $q_string = '';
  14 50       69  
    100          
    50          
3853 0         0 while (not /\G \z/oxgc) {
3854 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3855 1         17 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       1591 elsif (/\G \b (m) \b /oxgc) {
3868 209         1385 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         341 else {
3873 209 50       553 my $e = '';
  209 50       11420  
    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         26 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         659 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       255  
3899 97         1696 # $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         7 }
3903 96         253 else {
3904 96 50       305 my $e = '';
  96 50       12768  
    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         61 # $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         348 }
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         301 # 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         22 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     11 }
      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         9 # ''
4039 848         1709 elsif (/\G (?
4040 848 100       2224 my $q_string = '';
  8254 100       26220  
    100          
    50          
4041 4         10 while (not /\G \z/oxgc) {
4042 48         87 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4043 848         2058 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4044             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4045 7354         15936 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         3406 elsif (/\G (\") /oxgc) {
4052 1782 100       5557 my $qq_string = '';
  35079 100       116663  
    100          
    50          
4053 67         148 while (not /\G \z/oxgc) {
4054 12         25 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4055 1782         4036 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4056             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4057 33218         106502 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         2 elsif (/\G (\`) /oxgc) {
4064 1 50       4 my $qx_string = '';
  19 50       64  
    100          
    50          
4065 0         0 while (not /\G \z/oxgc) {
4066 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4067 1         4 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         1462 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4076 453 50       1261 my $regexp = '';
  4496 50       20133  
    100          
    50          
4077 0         0 while (not /\G \z/oxgc) {
4078 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4079 453         1520 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4080             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4081 4043         8768 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         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4106 6         11 $slash = 'm//';
4107             my $here_quote = $1;
4108             my $delimiter = $2;
4109 6 50       9  
4110 6         13 # get here document
4111 6         28 if ($here_script eq '') {
4112             $here_script = CORE::substr $_, pos $_;
4113 6 50       28 $here_script =~ s/.*?\n//oxm;
4114 6         61 }
4115 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4116 6         7 my $heredoc = $1;
4117 6         58 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         12 }
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         22  
4138 3         6 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4139 3         7 $slash = 'm//';
4140             my $here_quote = $1;
4141             my $delimiter = $2;
4142 3 50       6  
4143 3         7 # get here document
4144 3         11 if ($here_script eq '') {
4145             $here_script = CORE::substr $_, pos $_;
4146 3 50       23 $here_script =~ s/.*?\n//oxm;
4147 3         39 }
4148 3         6 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4149 3         6 my $heredoc = $1;
4150 3         35 my $indent = $2;
4151 3         23 $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         11 # <<~"HEREDOC"
4162 6         14 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4163 6         11 $slash = 'm//';
4164             my $here_quote = $1;
4165             my $delimiter = $2;
4166 6 50       12  
4167 6         12 # get here document
4168 6         21 if ($here_script eq '') {
4169             $here_script = CORE::substr $_, pos $_;
4170 6 50       32 $here_script =~ s/.*?\n//oxm;
4171 6         64 }
4172 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4173 6         8 my $heredoc = $1;
4174 6         50 my $indent = $2;
4175 6         16 $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         22 # <<~HEREDOC
4186 3         8 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4187 3         7 $slash = 'm//';
4188             my $here_quote = $1;
4189             my $delimiter = $2;
4190 3 50       6  
4191 3         8 # get here document
4192 3         20 if ($here_script eq '') {
4193             $here_script = CORE::substr $_, pos $_;
4194 3 50       26 $here_script =~ s/.*?\n//oxm;
4195 3         39 }
4196 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4197 3         4 my $heredoc = $1;
4198 3         38 my $indent = $2;
4199 3         10 $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         7 }
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         13 # <<~`HEREDOC`
4210 6         12 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4211 6         11 $slash = 'm//';
4212             my $here_quote = $1;
4213             my $delimiter = $2;
4214 6 50       11  
4215 6         10 # get here document
4216 6         18 if ($here_script eq '') {
4217             $here_script = CORE::substr $_, pos $_;
4218 6 50       40 $here_script =~ s/.*?\n//oxm;
4219 6         55 }
4220 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4221 6         7 my $heredoc = $1;
4222 6         45 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         300 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4235 72         185 $slash = 'm//';
4236             my $here_quote = $1;
4237             my $delimiter = $2;
4238 72 50       116  
4239 72         141 # get here document
4240 72         486 if ($here_script eq '') {
4241             $here_script = CORE::substr $_, pos $_;
4242 72 50       448 $here_script =~ s/.*?\n//oxm;
4243 72         713 }
4244 72         234 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4245             push @heredoc, $1 . qq{\n$delimiter\n};
4246             push @heredoc_delimiter, $delimiter;
4247 72         128 }
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         267  
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         91 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4286 36         81 $slash = 'm//';
4287             my $here_quote = $1;
4288             my $delimiter = $2;
4289 36 50       71  
4290 36         92 # get here document
4291 36         297 if ($here_script eq '') {
4292             $here_script = CORE::substr $_, pos $_;
4293 36 50       394 $here_script =~ s/.*?\n//oxm;
4294 36         535 }
4295 36         124 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         81 }
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         143 # <
4306 42         106 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4307 42         94 $slash = 'm//';
4308             my $here_quote = $1;
4309             my $delimiter = $2;
4310 42 50       80  
4311 42         106 # get here document
4312 42         291 if ($here_script eq '') {
4313             $here_script = CORE::substr $_, pos $_;
4314 42 50       314 $here_script =~ s/.*?\n//oxm;
4315 42         585 }
4316 42         145 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         106 }
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         171 # <<`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         62 #
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 'Elatin7::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         1469 # 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 [\)\}\]]
  5081         11614  
4390              
4391             ) /oxgc) { $slash = 'div'; return $1; }
4392              
4393             # yada-yada or triple-dot operator
4394             elsif (/\G (
4395 5081         23380 \.\.\.
  7         23  
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         27 [,;\(\{\[]
  8835         17461  
4452              
4453             )) /oxgc) { $slash = 'm//'; return $1; }
4454 8835         41367  
  15137         30143  
4455             # other any character
4456             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4457              
4458 15137         91669 # system error
4459             else {
4460             die __FILE__, ": Oops, this shouldn't happen!\n";
4461             }
4462             }
4463              
4464 0     1786 0 0 # escape Latin-7 string
4465 1786         5682 sub e_string {
4466             my($string) = @_;
4467 1786         2615 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         2659 # (and so on)
4474              
4475             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4476 1786 100 66     14117  
4477 1786 50       9363 # without { ... }
4478 1769         4233 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4479             if ($string !~ /<
4480             return $string;
4481             }
4482             }
4483 1769         4321  
4484 17 50       53 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         11580  
4489 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin7::PREMATCH()]}
4490 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4491             $e_string .= q{Elatin7::PREMATCH()};
4492             $slash = 'div';
4493             }
4494              
4495 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin7::MATCH()]}
4496 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4497             $e_string .= q{Elatin7::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} --> @{[Elatin7::POSTMATCH()]}
4508 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4509             $e_string .= q{Elatin7::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         15 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         19 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         24 # $ @ # \ ' " / ? ( ) [ ] < >
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 Elatin7
  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 Latin7::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 Latin7::eval \b /oxgc) { $e_string .= 'eval Latin7::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 .= 'Elatin7::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 Latin7::index \b /oxgc) { $e_string .= 'Latin7::index'; $slash = 'm//'; }
  0         0  
4600 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin7::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 Latin7::rindex \b /oxgc) { $e_string .= 'Latin7::rindex'; $slash = 'm//'; }
  0         0  
4604 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin7::rindex'; $slash = 'm//'; }
  0         0  
4605 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::lc'; $slash = 'm//'; }
  0         0  
4606 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::lcfirst'; $slash = 'm//'; }
  0         0  
4607 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::uc'; $slash = 'm//'; }
  0         0  
4608             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::ucfirst'; $slash = 'm//'; }
4609             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::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 .= 'Elatin7::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 .= 'Elatin7::glob'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin7::lc_'; $slash = 'm//'; }
  0         0  
4641 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin7::lcfirst_'; $slash = 'm//'; }
  0         0  
4642 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin7::uc_'; $slash = 'm//'; }
  0         0  
4643 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin7::ucfirst_'; $slash = 'm//'; }
  0         0  
4644             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin7::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 .= 'Elatin7::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 .= 'Elatin7::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 'Elatin7::split' . $e; }
4666 0         0  
  0         0  
4667             # split scalar value
4668             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin7::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 .= 'Elatin7::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4674 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin7::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 .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4677 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4678 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4679 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4680 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4681 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin7::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 .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4683             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {' '}; next E_STRING_LOOP; }
4684             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin7::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 .= 'Elatin7::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         52 \.\.\.
  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         68  
5149              
5150             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5151 31         111  
5152             # other any character
5153             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5154              
5155 131         345 # 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 102 #
5167             sub character_class {
5168 1919 100       3806 my($char,$modifier) = @_;
5169 1919 100       3223  
5170 52         101 if ($char eq '.') {
5171             if ($modifier =~ /s/) {
5172             return '${Elatin7::dot_s}';
5173 17         39 }
5174             else {
5175             return '${Elatin7::dot}';
5176             }
5177 35         74 }
5178             else {
5179             return Elatin7::classic_character_class($char);
5180             }
5181             }
5182              
5183             #
5184             # escape capture ($1, $2, $3, ...)
5185             #
5186 1867     212 0 3106 sub e_capture {
5187              
5188             return join '', '${', $_[0], '}';
5189             }
5190              
5191             #
5192             # escape transliteration (tr/// or y///)
5193 212     3 0 885 #
5194 3         16 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         4  
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       7 # /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         6 else {
5217             if ($variable eq '') {
5218             $e_tr = qq{Elatin7::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5219 2         8 }
5220             else {
5221             $e_tr = qq{Elatin7::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5222             }
5223             }
5224 1         4  
5225 3         5 # 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 14 #
5235             sub q_tr {
5236             my($charclass) = @_;
5237 6 50       7  
    0          
    0          
    0          
    0          
    0          
5238 6         17 # 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         2959 my($ope,$delimiter,$end_delimiter,$string) = @_;
5273              
5274 1264         1809 $slash = 'div';
5275              
5276             return join '', $ope, $delimiter, $string, $end_delimiter;
5277             }
5278              
5279             #
5280             # escape qq string (qq//, "", qx//, ``)
5281 1264     4044 0 6381 #
5282             sub e_qq {
5283 4044         10255 my($ope,$delimiter,$end_delimiter,$string) = @_;
5284              
5285 4044         5521 $slash = 'div';
5286 4044         4976  
5287             my $left_e = 0;
5288             my $right_e = 0;
5289 4044         4411  
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 4044         149518 ))/oxmsg;
5306              
5307             for (my $i=0; $i <= $#char; $i++) {
5308 4044 50 33     13897  
    50 33        
    100          
    100          
    50          
5309 113775         389360 # "\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] = Elatin7::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] = Elatin7::hexchr($1);
5327             }
5328              
5329 1         5 # \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 113775         977475  
5344 0 50       0 # \u \l \U \L \F \Q \E
5345 484         1006 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] = '@{[Elatin7::ucfirst qq<';
5365             $left_e++;
5366 0         0 }
5367 0         0 elsif ($char[$i] eq '\l') {
5368             $char[$i] = '@{[Elatin7::lcfirst qq<';
5369             $left_e++;
5370 0         0 }
5371 0         0 elsif ($char[$i] eq '\U') {
5372             $char[$i] = '@{[Elatin7::uc qq<';
5373             $left_e++;
5374 0         0 }
5375 0         0 elsif ($char[$i] eq '\L') {
5376             $char[$i] = '@{[Elatin7::lc qq<';
5377             $left_e++;
5378 0         0 }
5379 24         34 elsif ($char[$i] eq '\F') {
5380             $char[$i] = '@{[Elatin7::fc qq<';
5381             $left_e++;
5382 24         45 }
5383 0         0 elsif ($char[$i] eq '\Q') {
5384             $char[$i] = '@{[CORE::quotemeta qq<';
5385             $left_e++;
5386 0 50       0 }
5387 24         38 elsif ($char[$i] eq '\E') {
5388 24         29 if ($right_e < $left_e) {
5389             $char[$i] = '>]}';
5390             $right_e++;
5391 24         41 }
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         400 }
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} --> Elatin7::PREMATCH()
5444             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5445             $char[$i] = '@{[Elatin7::PREMATCH()]}';
5446             }
5447              
5448 44         126 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5449             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5450             $char[$i] = '@{[Elatin7::MATCH()]}';
5451             }
5452              
5453 45         121 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5454             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5455             $char[$i] = '@{[Elatin7::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         88 # ${ ... }
5463             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5464             $char[$i] = e_capture($1);
5465             }
5466             }
5467 0 50       0  
5468 4044         7827 # 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 4044     16 0 36552 #
5478             sub e_qw {
5479 16         75 my($ope,$delimiter,$end_delimiter,$string) = @_;
5480              
5481             $slash = 'div';
5482 16         36  
  16         223  
5483 483 50       768 # choice again delimiter
    0          
    0          
    0          
    0          
5484 16         107 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         158 }
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         244 my($string) = @_;
5527              
5528 93         153 $slash = 'm//';
5529              
5530 93         325 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5531 93         151  
5532             my $left_e = 0;
5533             my $right_e = 0;
5534 93         121  
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         8733 ))/oxmsg;
5551              
5552             for (my $i=0; $i <= $#char; $i++) {
5553 93 50 33     402  
    50 33        
    100          
    100          
    50          
5554 3177         10364 # "\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] = Elatin7::octchr($1);
5567             }
5568              
5569 1         4 # hexadecimal escape sequence
5570             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5571             $char[$i] = Elatin7::hexchr($1);
5572             }
5573              
5574 1         5 # \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 3177         25417  
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] = '@{[Elatin7::ucfirst qq<';
5590             $left_e++;
5591 0         0 }
5592 0         0 elsif ($char[$i] eq '\l') {
5593             $char[$i] = '@{[Elatin7::lcfirst qq<';
5594             $left_e++;
5595 0         0 }
5596 0         0 elsif ($char[$i] eq '\U') {
5597             $char[$i] = '@{[Elatin7::uc qq<';
5598             $left_e++;
5599 0         0 }
5600 0         0 elsif ($char[$i] eq '\L') {
5601             $char[$i] = '@{[Elatin7::lc qq<';
5602             $left_e++;
5603 0         0 }
5604 0         0 elsif ($char[$i] eq '\F') {
5605             $char[$i] = '@{[Elatin7::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} --> Elatin7::PREMATCH()
5669             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5670             $char[$i] = '@{[Elatin7::PREMATCH()]}';
5671             }
5672              
5673 8         50 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5674             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5675             $char[$i] = '@{[Elatin7::MATCH()]}';
5676             }
5677              
5678 8         44 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5679             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5680             $char[$i] = '@{[Elatin7::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         42 # ${ ... }
5688             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5689             $char[$i] = e_capture($1);
5690             }
5691             }
5692 0 50       0  
5693 93         231 # 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 703 #
5703 652   100     2834 sub e_qr {
5704             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5705 652         2882 $modifier ||= '';
5706 652 50       1153  
5707 652         1605 $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       1041  
    100          
5721 652         2119 # literal null string pattern
5722 8         9 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       35  
5731 2         6 # 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         11  
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       11 }
5769 642         1520  
5770             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5771             my $metachar = qr/[\@\\|[\]{^]/oxms;
5772 642         2568  
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       79928  
5798 642         2998 # 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         1259  
5828 642         1006 my $left_e = 0;
5829             my $right_e = 0;
5830             for (my $i=0; $i <= $#char; $i++) {
5831 642 50 66     1581  
    50 66        
    100          
    100          
    100          
    100          
5832 1872         9754 # "\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] = Elatin7::octchr($1);
5845             }
5846              
5847 1         5 # hexadecimal escape sequence
5848             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5849             $char[$i] = Elatin7::hexchr($1);
5850             }
5851              
5852             # \b{...} --> b\{...}
5853             # \B{...} --> B\{...}
5854             # \N{CHARNAME} --> N\{CHARNAME}
5855             # \p{PROPERTY} --> p\{PROPERTY}
5856 1         4 # \P{PROPERTY} --> P\{PROPERTY}
5857             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5858             $char[$i] = $1 . '\\' . $2;
5859             }
5860              
5861 6         18 # \p, \P, \X --> p, P, X
5862             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5863             $char[$i] = $1;
5864 4 100 100     12 }
    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         6417  
5869 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5870 6         83 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       445 # (and so on)
5888 328         825  
5889             if ($char[$i+1] eq ']') {
5890             $i++;
5891 3         7 }
5892 328 50       395  
5893 1379         2164 while (1) {
5894             if (++$i > $#char) {
5895 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5896 1379         2169 }
5897             if ($char[$i] eq ']') {
5898             my $right = $i;
5899 328 100       434  
5900 328         1874 # [...]
  30         66  
5901             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5902             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5903 90         147 }
5904             else {
5905             splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
5906 298         2217 }
5907 328         698  
5908             $i = $left;
5909             last;
5910             }
5911             }
5912             }
5913              
5914 328         844 # open character class [^...]
5915             elsif ($char[$i] eq '[^') {
5916             my $left = $i;
5917              
5918             # [^] make die "Unmatched [] in regexp ...\n"
5919 74 100       103 # (and so on)
5920 74         178  
5921             if ($char[$i+1] eq ']') {
5922             $i++;
5923 4         6 }
5924 74 50       1065  
5925 272         416 while (1) {
5926             if (++$i > $#char) {
5927 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5928 272         438 }
5929             if ($char[$i] eq ']') {
5930             my $right = $i;
5931 74 100       96  
5932 74         391 # [^...]
  30         72  
5933             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5934             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5935 90         157 }
5936             else {
5937             splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5938 44         191 }
5939 74         146  
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       323 # /i modifier
5952 20         31 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
5953             if (CORE::length(Elatin7::fc($char[$i])) == 1) {
5954             $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
5955 20         35 }
5956             else {
5957             $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::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] = '@{[Elatin7::ucfirst qq<';
5969             $left_e++;
5970 0         0 }
5971 0         0 elsif ($char[$i] eq '\l') {
5972             $char[$i] = '@{[Elatin7::lcfirst qq<';
5973             $left_e++;
5974 0         0 }
5975 1         3 elsif ($char[$i] eq '\U') {
5976             $char[$i] = '@{[Elatin7::uc qq<';
5977             $left_e++;
5978 1         3 }
5979 1         3 elsif ($char[$i] eq '\L') {
5980             $char[$i] = '@{[Elatin7::lc qq<';
5981             $left_e++;
5982 1         3 }
5983 18         32 elsif ($char[$i] eq '\F') {
5984             $char[$i] = '@{[Elatin7::fc qq<';
5985             $left_e++;
5986 18         39 }
5987 1         3 elsif ($char[$i] eq '\Q') {
5988             $char[$i] = '@{[CORE::quotemeta qq<';
5989             $left_e++;
5990 1 50       2 }
5991 21         40 elsif ($char[$i] eq '\E') {
5992 21         28 if ($right_e < $left_e) {
5993             $char[$i] = '>]}';
5994             $right_e++;
5995 21         44 }
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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6065             }
6066             }
6067              
6068 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
6069 8         19 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6070             if ($ignorecase) {
6071             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
6072 0         0 }
6073             else {
6074             $char[$i] = '@{[Elatin7::PREMATCH()]}';
6075             }
6076             }
6077              
6078 8 50       26 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
6079 8         19 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6080             if ($ignorecase) {
6081             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
6082 0         0 }
6083             else {
6084             $char[$i] = '@{[Elatin7::MATCH()]}';
6085             }
6086             }
6087              
6088 8 50       24 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
6089 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6090             if ($ignorecase) {
6091             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
6092 0         0 }
6093             else {
6094             $char[$i] = '@{[Elatin7::POSTMATCH()]}';
6095             }
6096             }
6097              
6098 6 0       17 # ${ 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] = '@{[Elatin7::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] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6110             }
6111             }
6112              
6113 0         0 # $scalar or @array
6114 21 100       50 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6115 21         120 $char[$i] = e_string($char[$i]);
6116             if ($ignorecase) {
6117             $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6118             }
6119             }
6120              
6121 11 100 33     33 # 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         946 }
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         462  
6140 642 50       2271 # make regexp string
6141 642 0 0     1324 $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         5351 }
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 5383 #
6161             sub qq_stuff {
6162             my($delimiter,$end_delimiter,$stuff) = @_;
6163 180 100       275  
6164 180         357 # scalar variable or array variable
6165             if ($stuff =~ /\A [\$\@] /oxms) {
6166             return $stuff;
6167             }
6168 100         353  
  80         175  
6169 80         237 # quote by delimiter
6170 80 50       192 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6171 80 50       138 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6172 80 50       115 next if $char eq $delimiter;
6173 80         150 next if $char eq $end_delimiter;
6174             if (not $octet{$char}) {
6175             return join '', 'qq', $char, $stuff, $char;
6176 80         396 }
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     37 sub e_qr_q {
6185             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6186 10         39 $modifier ||= '';
6187 10 50       12  
6188 10         21 $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       12  
    50          
6202 10         34 # literal null string pattern
6203 8         9 if ($string eq '') {
6204 8         10 $modifier =~ tr/bB//d;
6205             $modifier =~ tr/i//d;
6206             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6207             }
6208              
6209 8         59 # 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 7 #
6223             sub e_qr_qt {
6224 2 50       5 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6225              
6226             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6227 2         4  
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         56  
6240 2 50 33     10 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6241             for (my $i=0; $i <= $#char; $i++) {
6242             if (0) {
6243             }
6244 2         13  
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, Elatin7::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, Elatin7::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 (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6301             if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6302             $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6303 0         0 }
6304             else {
6305             $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::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         6  
6319             $delimiter = '/';
6320 2         4 $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 14 #
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     227 sub e_s1 {
6359             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6360 76         309 $modifier ||= '';
6361 76 50       120  
6362 76         415 $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       178  
    50          
6376 76         261 # literal null string pattern
6377 8         9 if ($string eq '') {
6378 8         9 $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       43  
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         291  
6421             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6422             my $metachar = qr/[\@\\|[\]{^]/oxms;
6423 68         282  
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       16082  
6453 68         521 # 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         134  
6483             # count '('
6484 253         444 my $parens = grep { $_ eq '(' } @char;
6485 68         100  
6486 68         95 my $left_e = 0;
6487             my $right_e = 0;
6488             for (my $i=0; $i <= $#char; $i++) {
6489 68 50 33     210  
    50 33        
    100          
    100          
    50          
    50          
6490 195         1155 # "\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] = Elatin7::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] = Elatin7::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         784  
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       22 elsif ($char[$i] eq '[') {
6542 13         50 my $left = $i;
6543             if ($char[$i+1] eq ']') {
6544 0         0 $i++;
6545 13 50       19 }
6546 58         89 while (1) {
6547             if (++$i > $#char) {
6548 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6549 58         128 }
6550             if ($char[$i] eq ']') {
6551             my $right = $i;
6552 13 50       24  
6553 13         164 # [...]
  0         0  
6554             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6555             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6556 0         0 }
6557             else {
6558             splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6559 13         70 }
6560 13         30  
6561             $i = $left;
6562             last;
6563             }
6564             }
6565             }
6566              
6567 13         36 # 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{@{[Elatin7::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, Elatin7::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       14 # /i modifier
6600 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6601             if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6602             $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6603 3         7 }
6604             else {
6605             $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::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] = '@{[Elatin7::ucfirst qq<';
6617             $left_e++;
6618 0         0 }
6619 0         0 elsif ($char[$i] eq '\l') {
6620             $char[$i] = '@{[Elatin7::lcfirst qq<';
6621             $left_e++;
6622 0         0 }
6623 0         0 elsif ($char[$i] eq '\U') {
6624             $char[$i] = '@{[Elatin7::uc qq<';
6625             $left_e++;
6626 0         0 }
6627 0         0 elsif ($char[$i] eq '\L') {
6628             $char[$i] = '@{[Elatin7::lc qq<';
6629             $left_e++;
6630 0         0 }
6631 0         0 elsif ($char[$i] eq '\F') {
6632             $char[$i] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6743             }
6744             }
6745              
6746 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
6747 4         15 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6748             if ($ignorecase) {
6749             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
6750 0         0 }
6751             else {
6752             $char[$i] = '@{[Elatin7::PREMATCH()]}';
6753             }
6754             }
6755              
6756 4 50       15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
6757 4         14 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6758             if ($ignorecase) {
6759             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
6760 0         0 }
6761             else {
6762             $char[$i] = '@{[Elatin7::MATCH()]}';
6763             }
6764             }
6765              
6766 4 50       13 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
6767 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6768             if ($ignorecase) {
6769             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
6770 0         0 }
6771             else {
6772             $char[$i] = '@{[Elatin7::POSTMATCH()]}';
6773             }
6774             }
6775              
6776 3 0       10 # ${ 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] = '@{[Elatin7::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] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6788             }
6789             }
6790              
6791 0         0 # $scalar or @array
6792 4 50       23 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6793 4         27 $char[$i] = e_string($char[$i]);
6794             if ($ignorecase) {
6795             $char[$i] = '@{[Elatin7::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         62 }
6803             else {
6804             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6805             }
6806             }
6807             }
6808 13         73  
6809 68         164 # make regexp string
6810 68 50       109 my $prematch = '';
6811 68         189 $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 862 #
6821 21   100     45 sub e_s1_q {
6822             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6823 21         72 $modifier ||= '';
6824 21 50       25  
6825 21         39 $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       28  
    50          
6839 21         55 # literal null string pattern
6840 8         9 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         39 # 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 31 #
6860             sub e_s1_qt {
6861 13 50       27 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6862              
6863             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6864 13         24  
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         260  
6877 13 50 33     160 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6878             for (my $i=0; $i <= $#char; $i++) {
6879             if (0) {
6880             }
6881 25         148  
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, Elatin7::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, Elatin7::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       13 # /i modifier
6937 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6938             if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6939             $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6940 0         0 }
6941             else {
6942             $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::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         23  
6956 13         18 $modifier =~ tr/i//d;
6957 13         16 $delimiter = '/';
6958 13         16 $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 104 #
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         70 my($ope,$delimiter,$end_delimiter,$string) = @_;
6998              
6999 16         21 $slash = 'div';
7000 16         93  
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         33  
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         15 }
7015              
7016             return join '', $ope, $delimiter, @char, $end_delimiter;
7017             }
7018              
7019             #
7020             # escape regexp (s/here/and here/modifier)
7021 16     97 0 51 #
7022 97   100     862 sub e_sub {
7023             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7024 97         553 $modifier ||= '';
7025 97 50       195  
7026 97         299 $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         272  
7038 36         51 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         143 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7059 97         142  
7060             my $e_modifier = $modifier =~ tr/e//d;
7061 97         142 my $r_modifier = $modifier =~ tr/r//d;
7062 97 50       141  
7063 97         240 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         238  
7070             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7071             $variable_basename =~ s/ \s+ \z//oxms;
7072 97         182  
7073 97 100       149 # quote replacement string
7074 97         228 my $e_replacement = '';
7075 17         36 if ($e_modifier >= 1) {
7076             $e_replacement = e_qq('', '', '', $replacement);
7077             $e_modifier--;
7078 17 100       77 }
7079 80         215 else {
7080             if ($delimiter2 eq "'") {
7081             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7082 16         32 }
7083             else {
7084             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7085             }
7086 64         178 }
7087              
7088             my $sub = '';
7089 97 100       180  
7090 97 100       198 # with /r
7091             if ($r_modifier) {
7092             if (0) {
7093             }
7094 8         20  
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             '$Elatin7::re_r=CORE::eval $Elatin7::re_r; ' x $e_modifier, # 5
7108             );
7109             }
7110              
7111             # s///r
7112 4         12 else {
7113              
7114 4 50       5 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 $Elatin7::re_r=%s; %s"%s$Elatin7::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             '$Elatin7::re_r=CORE::eval $Elatin7::re_r; ' x $e_modifier, # 5
7127             $prematch, # 6
7128             $variable, # 7
7129             );
7130             }
7131 4 50       11  
7132 8         18 # $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         206  
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             '$Elatin7::re_r=CORE::eval $Elatin7::re_r; ' x $e_modifier, # 5
7156             $variable, # 6
7157             $variable, # 7
7158             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7159             );
7160             }
7161              
7162             # s///
7163 22         165 else {
7164              
7165 67 100       102 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 $Elatin7::re_r=%s; %s%s="%s$Elatin7::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 $Elatin7::re_r=%s; %s%s="%s$Elatin7::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             '$Elatin7::re_r=CORE::eval $Elatin7::re_r; ' x $e_modifier, # 6
7185             $variable, # 7
7186             $prematch, # 8
7187             );
7188             }
7189             }
7190 67 50       397  
7191 97         301 # (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         150 # clear s/// variable
7197             $sub_variable = '';
7198 97         217 $bind_operator = '';
7199              
7200             return $sub;
7201             }
7202              
7203             #
7204             # escape regexp of split qr//
7205 97     74 0 703 #
7206 74   100     342 sub e_split {
7207             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7208 74         358 $modifier ||= '';
7209 74 50       122  
7210 74         165 $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       126  
7224 74         170 # /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         210  
7229             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7230             my $metachar = qr/[\@\\|[\]{^]/oxms;
7231 74         377  
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         29169 ))/oxmsg;
7256 74         270  
7257 74         109 my $left_e = 0;
7258             my $right_e = 0;
7259             for (my $i=0; $i <= $#char; $i++) {
7260 74 50 33     348  
    50 33        
    100          
    100          
    50          
    50          
7261 249         1376 # "\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] = Elatin7::octchr($1);
7274             }
7275              
7276 1         3 # hexadecimal escape sequence
7277             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7278             $char[$i] = Elatin7::hexchr($1);
7279             }
7280              
7281             # \b{...} --> b\{...}
7282             # \B{...} --> B\{...}
7283             # \N{CHARNAME} --> N\{CHARNAME}
7284             # \p{PROPERTY} --> p\{PROPERTY}
7285 1         5 # \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         853  
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       6 elsif ($char[$i] eq '[') {
7313 3         6 my $left = $i;
7314             if ($char[$i+1] eq ']') {
7315 0         0 $i++;
7316 3 50       4 }
7317 7         14 while (1) {
7318             if (++$i > $#char) {
7319 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7320 7         11 }
7321             if ($char[$i] eq ']') {
7322             my $right = $i;
7323 3 50       4  
7324 3         13 # [...]
  0         0  
7325             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7326             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7327 0         0 }
7328             else {
7329             splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
7330 3         11 }
7331 3         9  
7332             $i = $left;
7333             last;
7334             }
7335             }
7336             }
7337              
7338 3         9 # 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{@{[Elatin7::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, Elatin7::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       24 # /i modifier
7388 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
7389             if (CORE::length(Elatin7::fc($char[$i])) == 1) {
7390             $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
7391 0         0 }
7392             else {
7393             $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::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] = '@{[Elatin7::ucfirst qq<';
7405             $left_e++;
7406 0         0 }
7407 0         0 elsif ($char[$i] eq '\l') {
7408             $char[$i] = '@{[Elatin7::lcfirst qq<';
7409             $left_e++;
7410 0         0 }
7411 0         0 elsif ($char[$i] eq '\U') {
7412             $char[$i] = '@{[Elatin7::uc qq<';
7413             $left_e++;
7414 0         0 }
7415 0         0 elsif ($char[$i] eq '\L') {
7416             $char[$i] = '@{[Elatin7::lc qq<';
7417             $left_e++;
7418 0         0 }
7419 0         0 elsif ($char[$i] eq '\F') {
7420             $char[$i] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7501             }
7502             }
7503              
7504 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
7505 12         31 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7506             if ($ignorecase) {
7507             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
7508 0         0 }
7509             else {
7510             $char[$i] = '@{[Elatin7::PREMATCH()]}';
7511             }
7512             }
7513              
7514 12 50       49 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
7515 12         38 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7516             if ($ignorecase) {
7517             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
7518 0         0 }
7519             else {
7520             $char[$i] = '@{[Elatin7::MATCH()]}';
7521             }
7522             }
7523              
7524 12 50       61 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
7525 9         25 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7526             if ($ignorecase) {
7527             $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
7528 0         0 }
7529             else {
7530             $char[$i] = '@{[Elatin7::POSTMATCH()]}';
7531             }
7532             }
7533              
7534 9 0       40 # ${ 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] = '@{[Elatin7::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] = '@{[Elatin7::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] = '@{[Elatin7::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       218 # make regexp string
7568 74         160 $modifier =~ tr/i//d;
7569             if ($left_e > $right_e) {
7570 0         0 return join '', 'Elatin7::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7571             }
7572             return join '', 'Elatin7::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7573             }
7574              
7575             #
7576             # escape regexp of split qr''
7577 74     0 0 1133 #
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, Elatin7::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, Elatin7::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 (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
7675             if (CORE::length(Elatin7::fc($char[$i])) == 1) {
7676             $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
7677 0           }
7678             else {
7679             $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::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 '', 'Elatin7::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__